Changeset 37075 in project

Timestamp:

01/19/19 05:30:25 (2 years ago)

Author:

Jim Ursetto

Message:

4/uri-generic: backport relative path fixes from Chicken 5

Location:

release/4/uri-generic/trunk

Files:

• tests/run.scm (modified) (3 diffs)
• uri-generic.scm (modified) (4 diffs)
• uri-generic.setup (modified) (1 diff)

release/4/uri-generic/trunk/tests/run.scm

@@ -13 +13 @@
     ("http://ex/x/y/z" "http://ex/x/r" "../r")
 
-    ("http://ex/x/y"  "http://ex/x/q/r" "./q/r")
-    ("http://ex/x/y"  "http://ex/x/q/r#s" "./q/r#s")
-    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "./q/r#s/t")
+    ("http://ex/x/y"  "http://ex/x/q/r" "q/r")
+    ("http://ex/x/y"  "http://ex/x/q/r#s" "q/r#s")
+    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "q/r#s/t")
     ("http://ex/x/y"  "ftp://ex/x/q/r" "ftp://ex/x/q/r")
-    ("http://ex/x/y"  "http://ex/x/y"   "")
-    ("http://ex/x/y/" "http://ex/x/y/"  "")
-    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "")
-    ("http://ex/x/y/" "http://ex/x/y/z/" "./z/")
-    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal")
+    ("http://ex/x/y"  "http://ex/x/y"   "y")
+    ("http://ex/x/y/" "http://ex/x/y/"  ".")
+    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "pdq")
+    ("http://ex/x/y/" "http://ex/x/y/z/" "z/")
+    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "animal.rdf#Animal")
     ("file:/e/x/y/z" "file:/e/x/abc" "../abc")
-    ("file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc")   
+    ("file:/example2/x/y/z" "file:/example/x/abc" "../../../example/x/abc")
     ("file:/ex/x/y/z" "file:/ex/x/r" "../r")
-    ("file:/ex/x/y/z" "file:/r" "/r")        
-    ("file:/ex/x/y" "file:/ex/x/q/r" "./q/r")
-    ("file:/ex/x/y" "file:/ex/x/q/r#s" "./q/r#s")
-    ("file:/ex/x/y" "file:/ex/x/q/r#" "./q/r#")
-    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "./q/r#s/t")
+    ("file:/ex/x/y/z" "file:/r" "../../../r")
+    ("file:/ex/x/y" "file:/ex/x/q/r" "q/r")
+    ("file:/ex/x/y" "file:/ex/x/q/r#s" "q/r#s")
+    ("file:/ex/x/y" "file:/ex/x/q/r#" "q/r#")
+    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "q/r#s/t")
     ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r")
-    ("file:/ex/x/y" "file:/ex/x/y" "")
-    ("file:/ex/x/y/" "file:/ex/x/y/" "")
-    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "")
-    ("file:/ex/x/y/" "file:/ex/x/y/z/" "./z/")
+    ("file:/ex/x/y" "file:/ex/x/y" "y")
+    ("file:/ex/x/y/" "file:/ex/x/y/" ".")
+    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "pdq")
+    ("file:/ex/x/y/" "file:/ex/x/y/z/" "z/")
     ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
      "//meetings.example.com/cal#m1")
     ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
      "//meetings.example.com/cal#m1")
-    ("file:/some/dir/foo" "file:/some/dir/#blort" "./#blort")
-    ("file:/some/dir/foo" "file:/some/dir/#" "./#")
+    ("file:/some/dir/foo" "file:/some/dir/#blort" ".#blort")
+    ("file:/some/dir/foo" "file:/some/dir/#" ".#")
     ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000
-    ("http://example/x/y%2Fz"  "http://example/x/abc"     "./abc")
-    ("http://example/x/y/z"    "http://example/x%2Fabc"   "/x%2Fabc")
-    ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "/x%2Fabc")
-    ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "./abc")
+    ("http://example/x/y%2Fz"  "http://example/x/abc"     "abc")
+    ("http://example/x/y/z"    "http://example/x%2Fabc"   "../../x%2Fabc")
+    ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "../x%2Fabc")
+    ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "abc")
     ;; Ryan Lee
-    ("http://example/x/abc.efg" "http://example/x/" "./")
+    ("http://example/x/abc.efg" "http://example/x/" ".")
     ))
 
@@ -147 +147 @@
 
 (define reverse-extra-cases
-  `((,base ,base "")
-    (,base "http://a/b/c/e" "./e")
-    (,base "http://a/b/c/" "./")  ;; Not sure if the trailing slash belongs here
+  `((,base ,base "d;p")
+    (,base "http://a/b/c/e" "e")
+    (,base "http://a/b/c/" ".")
     (,base "http://a/b/e" "../e")
     (,base "http://a/b/c" "../c") ;; Slightly weird: dir in base, file in target
-    (,base "http://a/b/" "../")
-    (,base "http://a/" "/") ;; or "../../"
+    (,base "http://a/b/" "..")
+    (,base "http://a/" "../..") ;; or "/", but that's not convenient
     (,base "http://a" "//a") ; No relative representation possible
     (,base "http://b" "//b")
@@ -159 +159 @@
     (,base "http://b/c" "//b/c")
     (,base "ftp://a/b/c/d;p?q" "ftp://a/b/c/d;p?q")
-    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")))
+    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")
+    ;; Found by Jim Ursetto.  This would become "", which is not
+    ;; right when both are directories (see second case)
+    ("/foo/bar" "/foo/bar" "bar")
+    ("/foo/bar/" "/foo/bar/" ".")))
 
 (test-group "uri test"

release/4/uri-generic/trunk/uri-generic.scm

@@ -1188 +1188 @@
 
 (define (uri-relative-from uabs base)
-  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
+  (cond ((ucdiff? uri-scheme uabs base)    (update-URI uabs))
         ((ucdiff? uri-authority uabs base) (update-URI uabs 'scheme #f))
         ;; Special case: no relative representation for http://a/ -> http://a
@@ -1207 +1207 @@
                      'path (list)))
         (else
-         (update-URI uabs
+         (update-URI uabs
                      'scheme #f
                      'authority #f
                      'query #f
-                     'path (list)))))
+                     'path (match (uri-path uabs)
+                             (("") (list ""))
+                             ((p ... "") (list "."))
+                             ((p ... last) (list last)))))))
 
 (define (ucdiff? sel u1 u2)
@@ -1226 +1229 @@
          ((pabs ()) pabs)
          ((() base) (list))
-         ;; Construct a relative path segment if the paths share a
-         ;; leading segment other than a leading '/'
-         ((('/ . (and sa1 (ra1 . ra2))) ('/ . (and sb1 (rb1 . rb2))))
-          (make-rel-path
-           (if (string=? ra1 rb1)
-               (rel-path-from1 sa1 sb1)
-               pabs)))
+         ;; Construct a relative path segment
+         ((('/ . sa1) ('/ . sb1))
+          (rel-path-from1 sa1 sb1))
          (else (uri-error 'rel-path-from "Both URI paths must be absolute" pabs base))))
-
-(define (make-rel-path x)
-  (match x
-         ((or ('/ . rst) ("." . rst) (".." . rst)) x)
-         (else (cons "." x))))
 
 ;;  rel-path-from1 strips off trailing names from the supplied paths,
@@ -1245 +1239 @@
   (match-let* (((na . sa)  (reverse pabs))  
                ((nb . sb)  (reverse base)))
-     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
-       (if (null? rp)  (cond ((string=? na nb)  (list))
-                             (else              (list na)))
-           (append rp (list na))))))
+    (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
+      (match rp
+        (() (cond ((string=? na nb) (list))
+                  ((string=? na "") (list "."))
+                  (else (list na))))
+        ((rp1 ... (or ".." "."))
+         (if (string=? na "") rp (append rp (list na))))
+        (else (append rp (list na)) )))))
 
                           

release/4/uri-generic/trunk/uri-generic.setup

@@ -1 +1 @@
 ;; -*- Scheme -*-
 
-(standard-extension 'uri-generic "2.45")
+(standard-extension 'uri-generic "2.46")