Changeset 37075 in project


Ignore:
Timestamp:
01/19/19 05:30:25 (6 months ago)
Author:
zbigniew
Message:

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

Location:
release/4/uri-generic/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-generic/trunk/tests/run.scm

    r36547 r37075  
    1313    ("http://ex/x/y/z" "http://ex/x/r" "../r")
    1414
    15     ("http://ex/x/y"  "http://ex/x/q/r" "./q/r")
    16     ("http://ex/x/y"  "http://ex/x/q/r#s" "./q/r#s")
    17     ("http://ex/x/y"  "http://ex/x/q/r#s/t" "./q/r#s/t")
     15    ("http://ex/x/y"  "http://ex/x/q/r" "q/r")
     16    ("http://ex/x/y"  "http://ex/x/q/r#s" "q/r#s")
     17    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "q/r#s/t")
    1818    ("http://ex/x/y"  "ftp://ex/x/q/r" "ftp://ex/x/q/r")
    19     ("http://ex/x/y"  "http://ex/x/y"   "")
    20     ("http://ex/x/y/" "http://ex/x/y/"  "")
    21     ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "")
    22     ("http://ex/x/y/" "http://ex/x/y/z/" "./z/")
    23     ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal")
     19    ("http://ex/x/y"  "http://ex/x/y"   "y")
     20    ("http://ex/x/y/" "http://ex/x/y/"  ".")
     21    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "pdq")
     22    ("http://ex/x/y/" "http://ex/x/y/z/" "z/")
     23    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "animal.rdf#Animal")
    2424    ("file:/e/x/y/z" "file:/e/x/abc" "../abc")
    25     ("file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc")   
     25    ("file:/example2/x/y/z" "file:/example/x/abc" "../../../example/x/abc")
    2626    ("file:/ex/x/y/z" "file:/ex/x/r" "../r")
    27     ("file:/ex/x/y/z" "file:/r" "/r")       
    28     ("file:/ex/x/y" "file:/ex/x/q/r" "./q/r")
    29     ("file:/ex/x/y" "file:/ex/x/q/r#s" "./q/r#s")
    30     ("file:/ex/x/y" "file:/ex/x/q/r#" "./q/r#")
    31     ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "./q/r#s/t")
     27    ("file:/ex/x/y/z" "file:/r" "../../../r")
     28    ("file:/ex/x/y" "file:/ex/x/q/r" "q/r")
     29    ("file:/ex/x/y" "file:/ex/x/q/r#s" "q/r#s")
     30    ("file:/ex/x/y" "file:/ex/x/q/r#" "q/r#")
     31    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "q/r#s/t")
    3232    ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r")
    33     ("file:/ex/x/y" "file:/ex/x/y" "")
    34     ("file:/ex/x/y/" "file:/ex/x/y/" "")
    35     ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "")
    36     ("file:/ex/x/y/" "file:/ex/x/y/z/" "./z/")
     33    ("file:/ex/x/y" "file:/ex/x/y" "y")
     34    ("file:/ex/x/y/" "file:/ex/x/y/" ".")
     35    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "pdq")
     36    ("file:/ex/x/y/" "file:/ex/x/y/z/" "z/")
    3737    ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1"
    3838     "//meetings.example.com/cal#m1")
    3939    ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1"
    4040     "//meetings.example.com/cal#m1")
    41     ("file:/some/dir/foo" "file:/some/dir/#blort" "./#blort")
    42     ("file:/some/dir/foo" "file:/some/dir/#" "./#")
     41    ("file:/some/dir/foo" "file:/some/dir/#blort" ".#blort")
     42    ("file:/some/dir/foo" "file:/some/dir/#" ".#")
    4343    ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000
    44     ("http://example/x/y%2Fz"  "http://example/x/abc"     "./abc")
    45     ("http://example/x/y/z"    "http://example/x%2Fabc"   "/x%2Fabc")
    46     ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "/x%2Fabc")
    47     ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "./abc")
     44    ("http://example/x/y%2Fz"  "http://example/x/abc"     "abc")
     45    ("http://example/x/y/z"    "http://example/x%2Fabc"   "../../x%2Fabc")
     46    ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "../x%2Fabc")
     47    ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "abc")
    4848    ;; Ryan Lee
    49     ("http://example/x/abc.efg" "http://example/x/" "./")
     49    ("http://example/x/abc.efg" "http://example/x/" ".")
    5050    ))
    5151
     
    147147
    148148(define reverse-extra-cases
    149   `((,base ,base "")
    150     (,base "http://a/b/c/e" "./e")
    151     (,base "http://a/b/c/" "./")  ;; Not sure if the trailing slash belongs here
     149  `((,base ,base "d;p")
     150    (,base "http://a/b/c/e" "e")
     151    (,base "http://a/b/c/" ".")
    152152    (,base "http://a/b/e" "../e")
    153153    (,base "http://a/b/c" "../c") ;; Slightly weird: dir in base, file in target
    154     (,base "http://a/b/" "../")
    155     (,base "http://a/" "/") ;; or "../../"
     154    (,base "http://a/b/" "..")
     155    (,base "http://a/" "../..") ;; or "/", but that's not convenient
    156156    (,base "http://a" "//a") ; No relative representation possible
    157157    (,base "http://b" "//b")
     
    159159    (,base "http://b/c" "//b/c")
    160160    (,base "ftp://a/b/c/d;p?q" "ftp://a/b/c/d;p?q")
    161     (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")))
     161    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")
     162    ;; Found by Jim Ursetto.  This would become "", which is not
     163    ;; right when both are directories (see second case)
     164    ("/foo/bar" "/foo/bar" "bar")
     165    ("/foo/bar/" "/foo/bar/" ".")))
    162166
    163167(test-group "uri test"
  • release/4/uri-generic/trunk/uri-generic.scm

    r36558 r37075  
    11881188
    11891189(define (uri-relative-from uabs base)
    1190   (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
     1190  (cond ((ucdiff? uri-scheme uabs base)    (update-URI uabs))
    11911191        ((ucdiff? uri-authority uabs base) (update-URI uabs 'scheme #f))
    11921192        ;; Special case: no relative representation for http://a/ -> http://a
     
    12071207                     'path (list)))
    12081208        (else
    1209         (update-URI uabs
     1209        (update-URI uabs
    12101210                     'scheme #f
    12111211                     'authority #f
    12121212                     'query #f
    1213                      'path (list)))))
     1213                     'path (match (uri-path uabs)
     1214                             (("") (list ""))
     1215                             ((p ... "") (list "."))
     1216                             ((p ... last) (list last)))))))
    12141217
    12151218(define (ucdiff? sel u1 u2)
     
    12261229         ((pabs ()) pabs)
    12271230         ((() base) (list))
    1228          ;; Construct a relative path segment if the paths share a
    1229          ;; leading segment other than a leading '/'
    1230          ((('/ . (and sa1 (ra1 . ra2))) ('/ . (and sb1 (rb1 . rb2))))
    1231           (make-rel-path
    1232            (if (string=? ra1 rb1)
    1233                (rel-path-from1 sa1 sb1)
    1234                pabs)))
     1231         ;; Construct a relative path segment
     1232         ((('/ . sa1) ('/ . sb1))
     1233          (rel-path-from1 sa1 sb1))
    12351234         (else (uri-error 'rel-path-from "Both URI paths must be absolute" pabs base))))
    1236 
    1237 (define (make-rel-path x)
    1238   (match x
    1239          ((or ('/ . rst) ("." . rst) (".." . rst)) x)
    1240          (else (cons "." x))))
    12411235
    12421236;;  rel-path-from1 strips off trailing names from the supplied paths,
     
    12451239  (match-let* (((na . sa)  (reverse pabs)) 
    12461240               ((nb . sb)  (reverse base)))
    1247      (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
    1248        (if (null? rp)  (cond ((string=? na nb)  (list))
    1249                              (else              (list na)))
    1250            (append rp (list na))))))
     1241    (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
     1242      (match rp
     1243        (() (cond ((string=? na nb) (list))
     1244                  ((string=? na "") (list "."))
     1245                  (else (list na))))
     1246        ((rp1 ... (or ".." "."))
     1247         (if (string=? na "") rp (append rp (list na))))
     1248        (else (append rp (list na)) )))))
    12511249
    12521250                         
  • release/4/uri-generic/trunk/uri-generic.setup

    r36559 r37075  
    11;; -*- Scheme -*-
    22
    3 (standard-extension 'uri-generic "2.45")
     3(standard-extension 'uri-generic "2.46")
Note: See TracChangeset for help on using the changeset viewer.