[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-107-gc04c118

[Ludovic Courtès]

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=c04c11846127d481afc56a1d4e7f657460cd4f21

The branch, stable-2.0 has been updated
       via  c04c11846127d481afc56a1d4e7f657460cd4f21 (commit)
       via  4e81e9d9a37ee958bf4b9a636a8f106f1241f1ce (commit)
      from  261af76005f0e31f570bed201a2ef2a43cdd6e11 (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 -----------------------------------------------------------------
commit c04c11846127d481afc56a1d4e7f657460cd4f21
Author: Ludovic Courtès <address@hidden>
Date:   Tue Nov 27 23:02:15 2012 +0100

    vlist: Remove Texinfo markup from docstrings.
    
    * module/ice-9/vlist.scm: Remove Texinfo markup from docstrings with
      sed -e"s/@var{\([a-z0-9?!-]\+\)}/\U\1/g ; s/@code{\([^}]\+\)}/‘\1’/g".

commit 4e81e9d9a37ee958bf4b9a636a8f106f1241f1ce
Author: Daniel Hartwig <address@hidden>
Date:   Tue Nov 27 16:48:41 2012 +0800

    web client: correctly handle uri-query, etc. in relative URI headers
    
    * module/web/uri.scm (uri-pat): Make scheme part optional.
      (string->uri*): New private procedure to also parse relative URIs.
    * module/web/http.scm (declare-relative-uri-header!): Use that.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/vlist.scm |   94 ++++++++++++++++++++++++------------------------
 module/web/http.scm    |   12 ++-----
 module/web/uri.scm     |   30 ++++++++++-----
 3 files changed, 70 insertions(+), 66 deletions(-)

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index a09b374..0c0906c 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -208,7 +208,7 @@
         (make-vlist base 0))))))
 
 (define (vlist-cons item vlist)
-  "Return a new vlist with @var{item} as its head and @var{vlist} as its
+  "Return a new vlist with ITEM as its head and VLIST as its
 tail."
   ;; Note: Although the result of `vlist-cons' on a vhash is a valid
   ;; vlist, it is not a valid vhash.  The new item does not get a hash
@@ -219,14 +219,14 @@ tail."
   (block-cons item vlist #f))
 
 (define (vlist-head vlist)
-  "Return the head of @var{vlist}."
+  "Return the head of VLIST."
   (assert-vlist vlist)
   (let ((base   (vlist-base vlist))
         (offset (vlist-offset vlist)))
     (block-ref (block-content base) offset)))
 
 (define (vlist-tail vlist)
-  "Return the tail of @var{vlist}."
+  "Return the tail of VLIST."
   (assert-vlist vlist)
   (let ((base   (vlist-base vlist))
         (offset (vlist-offset vlist)))
@@ -236,7 +236,7 @@ tail."
                     (block-offset base)))))
 
 (define (vlist-null? vlist)
-  "Return true if @var{vlist} is empty."
+  "Return true if VLIST is empty."
   (assert-vlist vlist)
   (let ((base (vlist-base vlist)))
     (and (not (block-base base))
@@ -248,11 +248,11 @@ tail."
 ;;;
 
 (define (list->vlist lst)
-  "Return a new vlist whose contents correspond to @var{lst}."
+  "Return a new vlist whose contents correspond to LST."
   (vlist-reverse (fold vlist-cons vlist-null lst)))
 
 (define (vlist-fold proc init vlist)
-  "Fold over @var{vlist}, calling @var{proc} for each element."
+  "Fold over VLIST, calling PROC for each element."
   ;; FIXME: Handle multiple lists.
   (assert-vlist vlist)
   (let loop ((base   (vlist-base vlist))
@@ -267,7 +267,7 @@ tail."
                 (proc (block-ref (block-content base) offset) result))))))
 
 (define (vlist-fold-right proc init vlist)
-  "Fold over @var{vlist}, calling @var{proc} for each element, starting from
+  "Fold over VLIST, calling PROC for each element, starting from
 the last element."
   (assert-vlist vlist)
   (let loop ((index  (1- (vlist-length vlist)))
@@ -278,23 +278,23 @@ the last element."
           (proc (vlist-ref vlist index) result)))))
 
 (define (vlist-reverse vlist)
-  "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
+  "Return a new VLIST whose content are those of VLIST in reverse
 order."
   (vlist-fold vlist-cons vlist-null vlist))
 
 (define (vlist-map proc vlist)
-  "Map @var{proc} over the elements of @var{vlist} and return a new vlist."
+  "Map PROC over the elements of VLIST and return a new vlist."
   (vlist-fold (lambda (item result)
                 (vlist-cons (proc item) result))
               vlist-null
               (vlist-reverse vlist)))
 
 (define (vlist->list vlist)
-  "Return a new list whose contents match those of @var{vlist}."
+  "Return a new list whose contents match those of VLIST."
   (vlist-fold-right cons '() vlist))
 
 (define (vlist-ref vlist index)
-  "Return the element at index @var{index} in @var{vlist}."
+  "Return the element at index INDEX in VLIST."
   (assert-vlist vlist)
   (let loop ((index   index)
              (base    (vlist-base vlist))
@@ -306,8 +306,8 @@ order."
               (block-offset base)))))
 
 (define (vlist-drop vlist count)
-  "Return a new vlist that does not contain the @var{count} first elements of
address@hidden"
+  "Return a new vlist that does not contain the COUNT first elements of
+VLIST."
   (assert-vlist vlist)
   (let loop ((count  count)
              (base   (vlist-base vlist))
@@ -319,8 +319,8 @@ order."
               (block-offset base)))))
 
 (define (vlist-take vlist count)
-  "Return a new vlist that contains only the @var{count} first elements of
address@hidden"
+  "Return a new vlist that contains only the COUNT first elements of
+VLIST."
   (let loop ((count  count)
              (vlist  vlist)
              (result vlist-null))
@@ -331,8 +331,8 @@ order."
               (vlist-cons (vlist-head vlist) result)))))
 
 (define (vlist-filter pred vlist)
-  "Return a new vlist containing all the elements from @var{vlist} that
-satisfy @var{pred}."
+  "Return a new vlist containing all the elements from VLIST that
+satisfy PRED."
   (vlist-fold-right (lambda (e v)
                       (if (pred e)
                           (vlist-cons e v)
@@ -341,14 +341,14 @@ satisfy @var{pred}."
                     vlist))
 
 (define* (vlist-delete x vlist #:optional (equal? equal?))
-  "Return a new vlist corresponding to @var{vlist} without the elements
address@hidden to @var{x}."
+  "Return a new vlist corresponding to VLIST without the elements
+EQUAL? to X."
   (vlist-filter (lambda (e)
                   (not (equal? e x)))
                 vlist))
 
 (define (vlist-length vlist)
-  "Return the length of @var{vlist}."
+  "Return the length of VLIST."
   (assert-vlist vlist)
   (let loop ((base (vlist-base vlist))
              (len  (vlist-offset vlist)))
@@ -387,7 +387,7 @@ details."
                   vlists)))
 
 (define (vlist-for-each proc vlist)
-  "Call @var{proc} on each element of @var{vlist}.  The result is unspecified."
+  "Call PROC on each element of VLIST.  The result is unspecified."
   (vlist-fold (lambda (item x)
                 (proc item))
               (if #f #f)
@@ -442,13 +442,13 @@ details."
 ;;    pass a hash function or equality predicate.
 
 (define (vhash? obj)
-  "Return true if @var{obj} is a hash list."
+  "Return true if OBJ is a hash list."
   (and (vlist? obj)
        (block-hash-table? (vlist-base obj))))
 
 (define* (vhash-cons key value vhash #:optional (hash hash))
-  "Return a new hash list based on @var{vhash} where @var{key} is associated
-with @var{value}.  Use @var{hash} to compute @var{key}'s hash."
+  "Return a new hash list based on VHASH where KEY is associated
+with VALUE.  Use HASH to compute KEY's hash."
   (assert-vlist vhash)
   ;; We should also assert that it is a hash table.  Need to check the
   ;; performance impacts of that.  Also, vlist-null is a valid hash
@@ -493,18 +493,18 @@ with @var{value}.  Use @var{hash} to compute @var{key}'s 
hash."
 
 (define* (vhash-fold* proc init key vhash
                       #:optional (equal? equal?) (hash hash))
-  "Fold over all the values associated with @var{key} in @var{vhash}, with each
-call to @var{proc} having the form @code{(proc value result)}, where
address@hidden is the result of the previous call to @var{proc} and @var{init} 
the
-value of @var{result} for the first call to @var{proc}."
+  "Fold over all the values associated with KEY in VHASH, with each
+call to PROC having the form ‘(proc value result)’, where
+RESULT is the result of the previous call to PROC and INIT the
+value of RESULT for the first call to PROC."
   (%vhash-fold* proc init key vhash equal? hash))
 
 (define (vhash-foldq* proc init key vhash)
-  "Same as @code{vhash-fold*}, but using @code{hashq} and @code{eq?}."
+  "Same as ‘vhash-fold*’, but using ‘hashq’ and ‘eq?’."
   (%vhash-fold* proc init key vhash eq? hashq))
 
 (define (vhash-foldv* proc init key vhash)
-  "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
+  "Same as ‘vhash-fold*’, but using ‘hashv’ and ‘eqv?’."
   (%vhash-fold* proc init key vhash eqv? hashv))
 
 (define-inlinable (%vhash-assoc key vhash equal? hash)
@@ -532,23 +532,23 @@ value of @var{result} for the first call to @var{proc}."
                     (vlist-offset vhash))))
 
 (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
-  "Return the first key/value pair from @var{vhash} whose key is equal to
address@hidden according to the @var{equal?} equality predicate."
+  "Return the first key/value pair from VHASH whose key is equal to
+KEY according to the EQUAL? equality predicate."
   (%vhash-assoc key vhash equal? hash))
 
 (define (vhash-assq key vhash)
-  "Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
address@hidden"
+  "Return the first key/value pair from VHASH whose key is ‘eq?’ to
+KEY."
   (%vhash-assoc key vhash eq? hashq))
 
 (define (vhash-assv key vhash)
-  "Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
address@hidden"
+  "Return the first key/value pair from VHASH whose key is ‘eqv?’ to
+KEY."
   (%vhash-assoc key vhash eqv? hashv))
 
 (define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
-  "Remove all associations from @var{vhash} with @var{key}, comparing keys
-with @var{equal?}."
+  "Remove all associations from VHASH with KEY, comparing keys
+with EQUAL?."
   (if (vhash-assoc key vhash equal? hash)
       (vlist-fold (lambda (k+v result)
                     (let ((k (car k+v))
@@ -564,10 +564,10 @@ with @var{equal?}."
 (define vhash-delv (cut vhash-delete <> <> eqv? hashv))
 
 (define (vhash-fold proc init vhash)
-  "Fold over the key/pair elements of @var{vhash} from left to right, with
-each call to @var{proc} having the form @code{(@var{proc} key value result)},
-where @var{result} is the result of the previous call to @var{proc} and
address@hidden the value of @var{result} for the first call to @var{proc}."
+  "Fold over the key/pair elements of VHASH from left to right, with
+each call to PROC having the form ‘(PROC key value result)’,
+where RESULT is the result of the previous call to PROC and
+INIT the value of RESULT for the first call to PROC."
   (vlist-fold (lambda (key+value result)
                 (proc (car key+value) (cdr key+value)
                       result))
@@ -575,10 +575,10 @@ where @var{result} is the result of the previous call to 
@var{proc} and
               vhash))
 
 (define (vhash-fold-right proc init vhash)
-  "Fold over the key/pair elements of @var{vhash} from right to left, with
-each call to @var{proc} having the form @code{(@var{proc} key value result)},
-where @var{result} is the result of the previous call to @var{proc} and
address@hidden the value of @var{result} for the first call to @var{proc}."
+  "Fold over the key/pair elements of VHASH from right to left, with
+each call to PROC having the form ‘(PROC key value result)’,
+where RESULT is the result of the previous call to PROC and
+INIT the value of RESULT for the first call to PROC."
   (vlist-fold-right (lambda (key+value result)
                       (proc (car key+value) (cdr key+value)
                             result))
@@ -586,7 +586,7 @@ where @var{result} is the result of the previous call to 
@var{proc} and
                     vhash))
 
 (define* (alist->vhash alist #:optional (hash hash))
-  "Return the vhash corresponding to @var{alist}, an association list."
+  "Return the vhash corresponding to ALIST, an association list."
   (fold-right (lambda (pair result)
                 (vhash-cons (car pair) (cdr pair) result hash))
               vlist-null
diff --git a/module/web/http.scm b/module/web/http.scm
index f8dba30..216fddd 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1182,21 +1182,15 @@ treated specially, and is just returned as a plain 
string."
 (define (declare-uri-header! name)
   (declare-header! name
     (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
-    uri?
+    (@@ (web uri) absolute-uri?)
     write-uri))
 
 ;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
 (define (declare-relative-uri-header! name)
   (declare-header! name
     (lambda (str)
-      ;; XXX: Attempt to build an absolute URI, and fall back to a URI
-      ;; with no scheme to represent a relative URI.
-      ;; See <http://bugs.gnu.org/12827> for ideas to fully support
-      ;; relative URIs (aka. "URI references").
-      (or (string->uri str)                       ; absolute URI
-          (build-uri #f                           ; relative URI
-                     #:path str
-                     #:validate? #f)))
+      (or ((@@ (web uri) string->uri*) str)
+          (bad-header-component 'uri str)))
     uri?
     write-uri))
 
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 6ff0076..b688ea8 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -53,6 +53,9 @@
   (query uri-query)
   (fragment uri-fragment))
 
+(define (absolute-uri? x)
+  (and (uri? x) (uri-scheme x) #t))
+
 (define (uri-error message . args)
   (throw 'uri-error message args))
 
@@ -165,21 +168,21 @@ is valid."
 (define fragment-pat
   ".*")
 (define uri-pat
-  (format #f "^(~a):(//~a)?(~a)(\\?(~a))?(#(~a))?$"
+  (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$"
           scheme-pat authority-pat path-pat query-pat fragment-pat))
 (define uri-regexp
   (make-regexp uri-pat))
 
-(define (string->uri string)
+(define (string->uri* string)
   "Parse STRING into a URI object.  Return ‘#f’ if the string
 could not be parsed."
   (% (let ((m (regexp-exec uri-regexp string)))
        (if (not m) (abort))
-       (let ((scheme (string->symbol
-                      (string-downcase (match:substring m 1))))
-             (authority (match:substring m 2))
-             (path (match:substring m 3))
-             (query (match:substring m 5))
+       (let ((scheme (let ((str (match:substring m 2)))
+                       (and str (string->symbol (string-downcase str)))))
+             (authority (match:substring m 3))
+             (path (match:substring m 4))
+             (query (match:substring m 6))
              (fragment (match:substring m 7)))
          (call-with-values
              (lambda ()
@@ -191,6 +194,12 @@ could not be parsed."
      (lambda (k)
        #f)))
 
+(define (string->uri string)
+  "Parse STRING into a URI object.  Return ‘#f’ if the string
+could not be parsed."
+  (let ((uri (string->uri* string)))
+    (and uri (uri-scheme uri) uri)))
+
 (define *default-ports* (make-hash-table))
 
 (define (declare-default-port! scheme port)
@@ -208,8 +217,7 @@ could not be parsed."
   "Serialize URI to a string.  If the URI has a port that is the
 default port for its scheme, the port is not included in the
 serialization."
-  (let* ((scheme-str (string-append
-                      (symbol->string (uri-scheme uri)) ":"))
+  (let* ((scheme (uri-scheme uri))
          (userinfo (uri-userinfo uri))
          (host (uri-host uri))
          (port (uri-port uri))
@@ -217,7 +225,9 @@ serialization."
          (query (uri-query uri))
          (fragment (uri-fragment uri)))
     (string-append
-     scheme-str
+     (if scheme
+         (string-append (symbol->string scheme) ":")
+         "")
      (if host
          (string-append "//"
                         (if userinfo (string-append userinfo "@")


hooks/post-receive
-- 
GNU Guile