[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-105-g261af76

[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=261af76005f0e31f570bed201a2ef2a43cdd6e11

The branch, stable-2.0 has been updated
       via  261af76005f0e31f570bed201a2ef2a43cdd6e11 (commit)
       via  ca8be3f5b3e4ee55d6df361c402a2a5d57497062 (commit)
       via  9fbca4b32edfe1ba6e2159bbfa90e95315322f6c (commit)
      from  6356e0dc2f95cdf3883f92f480c130957be49817 (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 261af76005f0e31f570bed201a2ef2a43cdd6e11
Author: Ludovic Courtès <address@hidden>
Date:   Tue Nov 27 00:10:09 2012 +0100

    web client: Support relative URIs in some headers.
    
    Fixes <http://bugs.gnu.org/12827>.
    
    * module/web/http.scm (declare-relative-uri-header!): New procedure.
      ("Content-Location", "Referer"): Use it.
      Based on discussions with Daniel Hartwig <address@hidden>.

commit ca8be3f5b3e4ee55d6df361c402a2a5d57497062
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 26 23:51:20 2012 +0100

    Have `load-in-vicinity' look for `.go' files in %LOAD-COMPILED-PATH.
    
    Fixes <http://bugs.gnu.org/12519>.
    
    * module/ice-9/boot-9.scm (load-in-vicinity)[fresh-compiled-file-name]:
      New `scmstat' parameter; use it.
      [sans-extension]: New procedure.
      [load-absolute]: Call (stat ABS-PATH) from here.  Search a `.go' file
      from %LOAD-COMPILED-PATH before searching %COMPILE-FALLBACK-PATH.

commit 9fbca4b32edfe1ba6e2159bbfa90e95315322f6c
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 26 22:41:23 2012 +0100

    Split `load-in-vicinity' into small procedures.
    
    * module/ice-9/boot-9.scm (load-in-vicinity)[compiled-extension]: New
      variable.
      [compiled-file-name]: Rename to...
      [fallback-file-name]: ... this; update caller.  Use COMPILED-EXTENSION.
      [more-recent?, compile, warn-about-exception]: New procedures.
      [fresh-compiled-file-name]: Use them.

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

Summary of changes:
 module/ice-9/boot-9.scm |  139 +++++++++++++++++++++++++++++++----------------
 module/web/http.scm     |   19 ++++++-
 2 files changed, 109 insertions(+), 49 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index f097a69..e426374 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3569,6 +3569,10 @@ module '(ice-9 q) '(make-q q-length))}."
                 duplicate-case-datum bad-case-datum)))
 
 (define* (load-in-vicinity dir path #:optional reader)
+  "Load source file PATH in vicinity of directory DIR.  Use a pre-compiled
+version of PATH when available, and auto-compile one when none is available,
+reading PATH with READER."
+
   (define (canonical->suffix canon)
     (cond
      ((string-prefix? "/" canon) canon)
@@ -3578,6 +3582,49 @@ module '(ice-9 q) '(make-q q-length))}."
       (string-append "/" (substring canon 0 1) (substring canon 2)))
      (else canon)))
 
+  (define compiled-extension
+    ;; File name extension of compiled files.
+    (cond ((or (null? %load-compiled-extensions)
+               (string-null? (car %load-compiled-extensions)))
+           (warn "invalid %load-compiled-extensions"
+                 %load-compiled-extensions)
+           ".go")
+          (else (car %load-compiled-extensions))))
+
+  (define (more-recent? stat1 stat2)
+    ;; Return #t when STAT1 has an mtime greater than that of STAT2.
+    (or (> (stat:mtime stat1) (stat:mtime stat2))
+        (and (= (stat:mtime stat1) (stat:mtime stat2))
+             (>= (stat:mtimensec stat1)
+                 (stat:mtimensec stat2)))))
+
+  (define (fallback-file-name canon-path)
+    ;; Return the in-cache compiled file name for source file CANON-PATH.
+
+    ;; FIXME: would probably be better just to append SHA1(canon-path)
+    ;; to the %compile-fallback-path, to avoid deep directory stats.
+    (and %compile-fallback-path
+         (string-append %compile-fallback-path
+                        (canonical->suffix canon-path)
+                        compiled-extension)))
+
+  (define (compile file)
+    ;; Compile source FILE, lazily loading the compiler.
+    ((module-ref (resolve-interface '(system base compile))
+                 'compile-file)
+     file
+     #:opts %auto-compilation-options
+     #:env (current-module)))
+
+  (define (warn-about-exception key args)
+    (for-each (lambda (s)
+                (if (not (string-null? s))
+                    (format (current-warning-port) ";;; ~a\n" s)))
+              (string-split
+               (call-with-output-string
+                (lambda (port) (print-exception port #f key args)))
+               #\newline)))
+
   ;; Returns the .go file corresponding to `name'. Does not search load
   ;; paths, only the fallback path. If the .go file is missing or out of
   ;; date, and auto-compilation is enabled, will try auto-compilation, just
@@ -3587,32 +3634,15 @@ module '(ice-9 q) '(make-q q-length))}."
   ;; NB: Unless we need to compile the file, this function should not cause
   ;; (system base compile) to be loaded up. For that reason compiled-file-name
   ;; partially duplicates functionality from (system base compile).
-  ;;
-  (define (compiled-file-name canon-path)
-    ;; FIXME: would probably be better just to append SHA1(canon-path)
-    ;; to the %compile-fallback-path, to avoid deep directory stats.
-    (and %compile-fallback-path
-         (string-append
-          %compile-fallback-path
-          (canonical->suffix canon-path)
-          (cond ((or (null? %load-compiled-extensions)
-                     (string-null? (car %load-compiled-extensions)))
-                 (warn "invalid %load-compiled-extensions"
-                       %load-compiled-extensions)
-                 ".go")
-                (else (car %load-compiled-extensions))))))
-
-  (define (fresh-compiled-file-name name go-path)
+
+  (define (fresh-compiled-file-name name scmstat go-path)
+    ;; Return GO-PATH after making sure that it contains a freshly compiled
+    ;; version of source file NAME with stat SCMSTAT; return #f on failure.
     (catch #t
       (lambda ()
-        (let* ((scmstat (stat name))
-               (gostat  (and (not %fresh-auto-compile)
-                             (stat go-path #f))))
-          (if (and gostat
-                   (or (> (stat:mtime gostat) (stat:mtime scmstat))
-                       (and (= (stat:mtime gostat) (stat:mtime scmstat))
-                            (>= (stat:mtimensec gostat)
-                                (stat:mtimensec scmstat)))))
+        (let ((gostat (and (not %fresh-auto-compile)
+                           (stat go-path #f))))
+          (if (and gostat (more-recent? gostat scmstat))
               go-path
               (begin
                 (if gostat
@@ -3623,51 +3653,66 @@ module '(ice-9 q) '(make-q q-length))}."
                  (%load-should-auto-compile
                   (%warn-auto-compilation-enabled)
                   (format (current-warning-port) ";;; compiling ~a\n" name)
-                  (let ((cfn
-                         ((module-ref
-                               (resolve-interface '(system base compile))
-                               'compile-file)
-                              name
-                              #:opts %auto-compilation-options
-                              #:env (current-module))))
+                  (let ((cfn (compile name)))
                     (format (current-warning-port) ";;; compiled ~a\n" cfn)
                     cfn))
                  (else #f))))))
       (lambda (k . args)
         (format (current-warning-port)
                 ";;; WARNING: compilation of ~a failed:\n" name)
-        (for-each (lambda (s)
-                    (if (not (string-null? s))
-                        (format (current-warning-port) ";;; ~a\n" s)))
-                  (string-split
-                   (call-with-output-string
-                    (lambda (port) (print-exception port #f k args)))
-                   #\newline))
+        (warn-about-exception k args)
         #f)))
 
   (define (absolute-path? path)
     (string-prefix? "/" path))
 
+  (define (sans-extension file)
+    (let ((dot (string-rindex file #\.)))
+      (if dot
+          (substring file 0 dot)
+          file)))
+
   (define (load-absolute abs-path)
-    (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
-                 (and canon
-                      (let ((go-path (compiled-file-name canon)))
-                        (and go-path
-                             (fresh-compiled-file-name abs-path go-path)))))))
-      (if cfn
+    ;; Load from ABS-PATH, using a compiled file or auto-compiling if needed.
+    (define scmstat
+      (catch #t
+        (lambda ()
+          (stat abs-path))
+        (lambda (key . args)
+          (warn-about-exception key args)
+          #f)))
+
+    (define (pre-compiled)
+      (let ((go-path (search-path %load-compiled-path (sans-extension path)
+                                  %load-compiled-extensions #t)))
+        (and go-path
+             (let ((gostat (stat go-path #f)))
+               (and gostat (more-recent? gostat scmstat)
+                    go-path)))))
+
+    (define (fallback)
+      (let ((canon (false-if-exception (canonicalize-path abs-path))))
+        (and canon
+             (let ((go-path (fallback-file-name canon)))
+               (and go-path
+                    (fresh-compiled-file-name abs-path scmstat go-path))))))
+
+    (let ((compiled (and scmstat
+                         (or (pre-compiled) (fallback)))))
+      (if compiled
           (begin
             (if %load-hook
                 (%load-hook abs-path))
-            (load-compiled cfn))
+            (load-compiled compiled))
           (start-stack 'load-stack
                        (primitive-load abs-path)))))
-  
+
   (save-module-excursion
    (lambda ()
      (with-fluids ((current-reader reader)
                    (%file-port-name-canonicalization 'relative))
        (cond
-        ((or (absolute-path? path))
+        ((absolute-path? path)
          (load-absolute path))
         ((absolute-path? dir)
          (load-absolute (in-vicinity dir path)))
diff --git a/module/web/http.scm b/module/web/http.scm
index 342f435..f8dba30 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1185,6 +1185,21 @@ treated specially, and is just returned as a plain 
string."
     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)))
+    uri?
+    write-uri))
+
 ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
 (define (declare-quality-list-header! name)
   (declare-header! name
@@ -1437,7 +1452,7 @@ treated specially, and is just returned as a plain 
string."
 
 ;; Content-Location = ( absoluteURI | relativeURI )
 ;;
-(declare-uri-header! "Content-Location")
+(declare-relative-uri-header! "Content-Location")
 
 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
 ;;
@@ -1726,7 +1741,7 @@ treated specially, and is just returned as a plain 
string."
 
 ;; Referer = ( absoluteURI | relativeURI )
 ;;
-(declare-uri-header! "Referer")
+(declare-relative-uri-header! "Referer")
 
 ;; TE = #( t-codings )
 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )


hooks/post-receive
-- 
GNU Guile