[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-93-gda03005

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=da03005a2a362847db2ac7e876cd9e31b20f9c73

The branch, stable-2.0 has been updated
       via  da03005a2a362847db2ac7e876cd9e31b20f9c73 (commit)
       via  1be6c7d34d7e1e40e78c8983bd8b40b3fbf7d01c (commit)
       via  47153f29b02cee6324aec523cfa44b48e1cb29b9 (commit)
      from  c05805a4ea764dec5a0559edefcdfb9761191d07 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 libguile/srfi-13.c     |   11 +++++---
 module/web/http.scm    |   61 ++++++++++++++++++++++++++++-------------------
 module/web/request.scm |   13 +++++++++-
 3 files changed, 55 insertions(+), 30 deletions(-)

diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 75feae3..2834553 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -1,6 +1,6 @@
 /* srfi-13.c --- SRFI-13 procedures for Guile
  *
- * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software 
Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free 
Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -719,7 +719,8 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
   MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              3, start, cstart,
                              4, end, cend);
-  if (SCM_UNBNDP (char_pred))
+  if (SCM_UNBNDP (char_pred)
+      || scm_is_eq (char_pred, scm_char_set_whitespace))
     {
       while (cstart < cend)
        {
@@ -794,7 +795,8 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 
3, 0,
   MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              3, start, cstart,
                              4, end, cend);
-  if (SCM_UNBNDP (char_pred))
+  if (SCM_UNBNDP (char_pred)
+      || scm_is_eq (char_pred, scm_char_set_whitespace))
     {
       while (cstart < cend)
        {
@@ -869,7 +871,8 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 
0,
   MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              3, start, cstart,
                              4, end, cend);
-  if (SCM_UNBNDP (char_pred))
+  if (SCM_UNBNDP (char_pred)
+      || scm_is_eq (char_pred, scm_char_set_whitespace))
     {
       while (cstart < cend)
        {
diff --git a/module/web/http.scm b/module/web/http.scm
index 879923f..d579c52 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -185,7 +185,7 @@ body was reached (i.e., a blank line)."
             sym
             (read-continuation-line
              port
-             (string-trim-both line char-whitespace? (1+ delim)))))))))
+             (string-trim-both line char-set:whitespace (1+ delim)))))))))
 
 (define (parse-header sym val)
   "Parse @var{val}, a string, with the parser registered for the header
@@ -240,7 +240,22 @@ ordered alist."
 (define (bad-header sym val)
   (throw 'bad-header sym val))
 (define (bad-header-component sym val)
-  (throw 'bad-header sym val))
+  (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header: ~a\n" (header->string sym) val))
+           (_ (default-printer)))
+         args))
+(define (bad-header-component-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header component: ~a\n" sym val))
+           (_ (default-printer)))
+         args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)
 
 (define (parse-opaque-string str)
   str)
@@ -277,7 +292,7 @@ ordered alist."
   (let lp ((i start))
     (if (< i end)
         (let* ((idx (string-index str delim i end))
-               (tok (string-trim-both str char-whitespace? i (or idx end))))
+               (tok (string-trim-both str char-set:whitespace i (or idx end))))
           (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
         '())))
 
@@ -420,13 +435,13 @@ ordered alist."
          (cond
           ((string-rindex part #\;)
            => (lambda (idx)
-                (let ((qpart (string-trim-both part char-whitespace? (1+ 
idx))))
+                (let ((qpart (string-trim-both part char-set:whitespace (1+ 
idx))))
                   (if (string-prefix? "q=" qpart)
                       (cons (parse-quality qpart 2)
-                            (string-trim-both part char-whitespace? 0 idx))
+                            (string-trim-both part char-set:whitespace 0 idx))
                       (bad-header-component 'quality qpart)))))
           (else
-           (cons 1000 (string-trim-both part char-whitespace?)))))
+           (cons 1000 (string-trim-both part char-set:whitespace)))))
        (string-split str #\,)))
 
 (define (validate-quality-list l)
@@ -541,15 +556,15 @@ ordered alist."
 ;; param-component = token [ "=" (token | quoted-string) ] \
 ;;    *(";" token [ "=" (token | quoted-string) ])
 ;;
+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))
 (define* (parse-param-component str #:optional
                                 (val-parser default-val-parser)
                                 (start 0) (end (string-length str)))
   (let lp ((i start) (out '()))
     (if (not (< i end))
         (values (reverse! out) end)
-        (let ((delim (string-index str
-                                   (lambda (c) (memq c '(#\, #\; #\=)))
-                                   i)))
+        (let ((delim (string-index str param-delimiters i)))
           (let ((k (string->symbol
                     (substring str i (trim-whitespace str i (or delim end)))))
                 (delimc (and delim (string-ref str delim))))
@@ -561,13 +576,8 @@ ordered alist."
                        (if (and (< i end) (eqv? (string-ref str i) #\"))
                            (parse-qstring str i end #:incremental? #t)
                            (let ((delim
-                                  (or (string-index
-                                       str
-                                       (lambda (c)
-                                         (or (eqv? c #\;)
-                                             (eqv? c #\,)
-                                             (char-whitespace? c)))
-                                       i end)
+                                  (or (string-index str param-value-delimiters
+                                                    i end)
                                       end)))
                              (values (substring str i delim)
                                      delim)))))
@@ -853,7 +863,7 @@ ordered alist."
 (define* (parse-credentials str #:optional (val-parser default-val-parser)
                             (start 0) (end (string-length str)))
   (let* ((start (skip-whitespace str start end))
-         (delim (or (string-index str char-whitespace? start end) end)))
+         (delim (or (string-index str char-set:whitespace start end) end)))
     (if (= start end)
         (bad-header-component 'authorization str))
     (let ((scheme (string->symbol
@@ -1038,8 +1048,8 @@ not have to have a scheme or host name.  The result is a 
URI object."
   "Read the first line of an HTTP request from @var{port}, returning
 three values: the method, the URI, and the version."
   (let* ((line (read-line* port))
-         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
-         (d1 (string-rindex line char-whitespace?)))
+         (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+         (d1 (string-rindex line char-set:whitespace)))
     (if (and d0 d1 (< d0 d1))
         (values (parse-http-method line 0 d0)
                 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
@@ -1100,14 +1110,14 @@ three values: the method, the URI, and the version."
 three values: the HTTP version, the response code, and the \"reason
 phrase\"."
   (let* ((line (read-line* port))
-         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
-         (d1 (and d0 (string-index line char-whitespace?
+         (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+         (d1 (and d0 (string-index line char-set:whitespace
                                    (skip-whitespace line d0)))))
     (if (and d0 d1)
         (values (parse-http-version line 0 d0)
                 (parse-non-negative-integer line (skip-whitespace line d0 d1)
                                             d1)
-                (string-trim-both line char-whitespace? d1))
+                (string-trim-both line char-set:whitespace d1))
         (bad-response "Bad Response-Line: ~s" line))))
 
 (define (write-response-line version code reason-phrase port)
@@ -1488,9 +1498,10 @@ phrase\"."
             (map (lambda (x)
                    (let ((eq (string-index x #\=)))
                      (if (and eq (= eq (string-rindex x #\=)))
-                         (cons (string->symbol
-                                (string-trim x char-whitespace? 0 eq))
-                               (string-trim-right x char-whitespace? (1+ eq)))
+                         (cons
+                          (string->symbol
+                           (string-trim x char-set:whitespace 0 eq))
+                          (string-trim-right x char-set:whitespace (1+ eq)))
                          (bad-header 'content-type str))))
                  (cdr parts)))))
   (lambda (val)
diff --git a/module/web/request.scm b/module/web/request.scm
index 8259887..40d4a66 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -1,6 +1,6 @@
 ;;; HTTP request objects
 
-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -131,6 +131,17 @@
 (define (bad-request message . args)
   (throw 'bad-request message args))
 
+(define (bad-request-printer port key args default-printer)
+  (apply (case-lambda
+           ((msg args)
+            (display "Bad request: " port)
+            (apply format port msg args)
+            (newline port))
+           (_ (default-printer)))
+         args))
+
+(set-exception-printer! 'bad-request bad-request-printer)
+
 (define (non-negative-integer? n)
   (and (number? n) (>= n 0) (exact? n) (integer? n)))
                                     


hooks/post-receive
-- 
GNU Guile