Changeset 10017


Ignore:
Timestamp:
09/24/05 14:55:26 (16 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/tests/pathname-tests.lisp

    r10016 r10017  
    3131(in-package #:pathname-tests)
    3232
    33 (defmacro expect (test-form)
    34   `(unless (ignore-errors ,test-form)
    35      (format t "Expected ~S~%" ',test-form)))
    36 
    3733(defmacro signals-error (form error-name)
    3834  `(locally (declare (optimize safety))
     
    4844    (unless (and (pathnamep pathname)
    4945                 (not (typep pathname 'logical-pathname)))
    50 ;;       (format t "~&~S => ~S; expected ~S~%" pathname (type-of pathname) 'pathname)
    5146      (setf ok nil))
    5247    (unless (and (equal directory expected-directory)
    5348                 (equal name      expected-name)
    5449                 (equal type      expected-type))
    55 ;;       (format t "~&~S => ~S ~S ~S; expected ~S ~S ~S~%"
    56 ;;               pathname directory name type expected-directory expected-name expected-type)
    5750      (setf ok nil))
    5851    ok))
     
    7265         (ok t))
    7366    (unless (typep pathname 'logical-pathname)
    74 ;;       (format t "~&~S => ~S; expected ~S~%" pathname (type-of pathname) 'logical-pathname)
    7567      (setf ok nil))
    7668    ;; "The device component of a logical pathname is always :UNSPECIFIC..." 19.3.2.1
    7769    #-allegro ;; Except on Allegro, where it's NIL.
    7870    (unless (eq (pathname-device pathname) :unspecific)
    79 ;;       (format t "~S => device is ~S, not ~S~%"
    80 ;;               pathname (pathname-device pathname) :unspecific)
    8171      (setf ok nil))
    8272    (unless (and (or (not (stringp host))
     
    8676                 (funcall test type expected-type)
    8777                 (eql version expected-version))
    88 ;;       (format t "~&~S => ~S ~S ~S ~S ~S; expected ~S ~S ~S ~S ~S~%"
    89 ;;               pathname
    90 ;;               host directory name type version
    91 ;;               expected-host expected-directory expected-name expected-type
    92 ;;               expected-version)
    9378      (setf ok nil))
    9479    ok))
     80
     81(defun check-merge-pathnames (pathname default-pathname expected-result)
     82  (let* ((result (merge-pathnames pathname default-pathname))
     83         (test #-allegro 'equal
     84               #+allegro (if (typep result 'logical-pathname)
     85                             'equalp
     86                             'equal)))
     87    (and (funcall test (pathname-host result) (pathname-host expected-result))
     88         (funcall test (pathname-directory result) (pathname-directory expected-result))
     89         (funcall test (pathname-name result) (pathname-name expected-result))
     90         (funcall test (pathname-type result) (pathname-type expected-result)))))
    9591
    9692(defun check-translate-pathname (args expected)
     
    9995  (declare (type string expected))
    10096  (let ((result (namestring (apply 'translate-pathname args))))
    101 ;;     (unless (equal result
    102 ;;                    #-windows expected
    103 ;;                    #+windows (substitute #\\ #\/ expected))
    104 ;;       (format t "(translate-pathname ~S ~S ~S) => ~S; expected ~S~%"
    105 ;;               (first args) (second args) (third args) result expected))))
    10697    (equal result
    10798           #-windows expected
     
    575566
    576567;; TRANSLATE-LOGICAL-PATHNAME
    577 #+clisp
    578 (expect (equal (translate-logical-pathname "effluvia:foo.bar") #p"/usr/local/foo.bar"))
     568#+(or abcl clisp)
     569(deftest translate-logical-pathname.1
     570  (equal (translate-logical-pathname "effluvia:foo.bar") #p"/usr/local/foo.bar")
     571  t)
     572
    579573#+(or sbcl cmu)
    580 ;; Device mismatch.
    581 (progn
    582   (expect (eq (pathname-device (translate-logical-pathname "effluvia:foo.bar")) :unspecific))
    583   (expect (eq (pathname-device #p"/usr/local/foo/bar") nil)))
    584 (expect (string= (namestring (translate-logical-pathname "effluvia:foo.bar"))
    585                  #-windows "/usr/local/foo.bar"
    586                  #+windows "\\usr\\local\\foo.bar"))
    587 (expect (string= (namestring (translate-logical-pathname "effluvia:foo;bar.txt"))
    588                  #-windows "/usr/local/foo/bar.txt"
    589                  #+windows "\\usr\\local\\foo\\bar.txt"))
    590 
    591 #-allegro
    592 (check-logical-pathname #p"effluvia:Foo.Bar" "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
    593 #+allegro
    594 (check-logical-pathname #p"effluvia:Foo.Bar" "effluvia" nil "Foo" "Bar" nil)
     574(deftest translate-logical-pathname.2
     575  ;; Device mismatch.
     576  (and (eq (pathname-device (translate-logical-pathname "effluvia:foo.bar"))
     577           :unspecific)
     578       (eq (pathname-device #p"/usr/local/foo/bar")
     579           nil))
     580  t)
     581
     582(deftest translate-logical-pathname.3
     583  (check-namestring (translate-logical-pathname "effluvia:foo.bar")
     584                    "/usr/local/foo.bar")
     585  t)
     586
     587(deftest translate-logical-pathname.4
     588  (check-namestring (translate-logical-pathname "effluvia:foo;bar.txt")
     589                    "/usr/local/foo/bar.txt")
     590  t)
     591
     592(deftest translate-logical-pathname.5
     593  #-allegro
     594  (check-logical-pathname #p"effluvia:Foo.Bar" "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
     595  #+allegro
     596  ;; Allegro preserves case.
     597  (check-logical-pathname #p"effluvia:Foo.Bar" "effluvia" nil "Foo" "Bar" nil)
     598  t)
    595599
    596600;; "TRANSLATE-PATHNAME [and thus also TRANSLATE-LOGICAL-PATHNAME] maps
    597601;; customary case in SOURCE into customary case in the output pathname."
    598 (deftest translate-logical-pathname.1
     602(deftest translate-logical-pathname.6
    599603  #-allegro
    600604  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
     
    665669  (equal (enough-namestring "demo2:test;foo.lisp")
    666670         #+sbcl "DEMO2:;TEST;FOO.LISP"
    667          #+cmu #p"DEMO2:TEST;FOO.LISP" ;; BUG (must be string or NIL)
     671         #+cmu "DEMO2:TEST;FOO.LISP"
    668672         #+clisp "TEST;FOO.LISP"
    669673         #+allegro "/test/foo.lisp" ;; BUG
     
    795799  t)
    796800
    797 (eval-when (:compile-toplevel :load-toplevel :execute)
     801;; (eval-when (:compile-toplevel :load-toplevel :execute)
    798802  (setf (logical-pathname-translations "scratch")
    799         '(("**;*.*.*" "/usr/local/doc/**/*"))))
    800 
    801 #-(or allegro clisp)
    802 ;; FIXME Figure out why CLISP and Allegro don't like this test!
    803 ;; FIXME Figure out how to wrap this in DEFTEST!
    804 (loop for (expected-result . params) in
    805   `(;; trivial merge
    806         (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/")
    807         ;; If pathname does not specify a host, device, directory,
    808         ;; name, or type, each such component is copied from
    809         ;; default-pathname.
    810         ;; 1) no name, no type
    811         (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type")
    812         ;; 2) no directory, no type
    813         (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type")
    814         ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
    815         ;; as a name)
    816         (#p"/dir/name.supplied-type"
    817          ,(make-pathname :type "supplied-type")
    818          #p"/dir/name.type")
    819         ;; If (pathname-directory pathname) is a list whose car is
    820         ;; :relative, and (pathname-directory default-pathname) is a
    821         ;; list, then the merged directory is [...]
    822         (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee")
    823         ;; except that if the resulting list contains a string or
    824         ;; :wild immediately followed by :back, both of them are
    825         ;; removed.
    826         (#P"/aaa/bbb/ccc/blah/eee"
    827          ;; "../" in a namestring is parsed as :up not :back, so make-pathname
    828          ,(make-pathname :directory '(:relative :back "blah"))
    829          #p"/aaa/bbb/ccc/ddd/eee")
    830         ;; If (pathname-directory default-pathname) is not a list or
    831         ;; (pathname-directory pathname) is not a list whose car is
    832         ;; :relative, the merged directory is (or (pathname-directory
    833         ;; pathname) (pathname-directory default-pathname))
    834         (#P"/absolute/path/name.type"
    835          #p"/absolute/path/name"
    836          #p"/dir/default-name.type")
    837         ;; === logical pathnames ===
    838         ;; recognizes a logical pathname namestring when
    839         ;; default-pathname is a logical pathname
    840         ;; FIXME: 0.6.12.23 fails this one.
    841         ;;
    842         ;; And, as it happens, it's right to fail it. Because
    843         ;; #p"name1" is read in with the ambient *d-p-d* value, which
    844         ;; has a physical (Unix) host; therefore, the host of the
    845         ;; default-pathname argument to merge-pathnames is
    846         ;; irrelevant. The result is (correctly) different if
    847         ;; '#p"name1"' is replaced by "name1", below, though it's
    848         ;; still not what one might expect... -- CSR, 2002-05-09
    849         #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;")
    850         ;; or when the namestring begins with the name of a defined
    851         ;; logical host followed by a colon [I assume that refers to pathname
    852         ;; rather than default-pathname]
    853         (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;")
    854         ;; conduct the previous set of tests again, with a lpn first argument
    855         (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/")
    856         (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
    857          #p"scratch:supplied-dir;"
    858          #p"/dir/name.type")
    859         (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
    860          #p"scratch:;supplied-name"
    861          #p"/dir/name.type")
    862         (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
    863          ,(make-pathname :host "scratch" :type "supplied-type")
    864          #p"/dir/name.type")
    865         (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
    866          ,(make-pathname :host "scratch"
    867                          :directory '(:relative "foo")
    868                          :name "bar")
    869          #p"/aaa/bbb/ccc/ddd/eee")
    870         (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
    871          ,(make-pathname :host "scratch"
    872                          :directory '(:relative :back "foo")
    873                          :name "bar")
    874          #p"/aaa/bbb/ccc/ddd/eee")
    875         (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
    876          #p"scratch:absolute;path;name" #p"/dir/default-name.type")
    877 
    878         ;; FIXME: test version handling in LPNs
    879         )
    880   do (let ((result (apply #'merge-pathnames params)))
    881        (macrolet ((frob (op)
    882                     `(expect (equal (,op result) (,op expected-result)))))
    883          (frob pathname-host)
    884          (frob pathname-directory)
    885          (frob pathname-name)
    886          (frob pathname-type))))
    887 
     803        '(("**;*.*.*" "/usr/local/doc/**/*")))
     804;;   )
     805
     806;; Trivial merge.
    888807(deftest sbcl.27
     808  (check-merge-pathnames #p"foo" #p"/usr/local/doc/" #p"/usr/local/doc/foo")
     809  t)
     810
     811;; If pathname does not specify a host, device, directory, name, or type, each
     812;; such component is copied from default-pathname.
     813;; 1) no name, no type
     814(deftest sbcl.28
     815  (check-merge-pathnames #p"/supplied-dir/" #p"/dir/name.type"
     816                         #p"/supplied-dir/name.type")
     817  t)
     818;; 2) no directory, no type
     819(deftest sbcl.29
     820  (check-merge-pathnames #p"supplied-name" #p"/dir/name.type"
     821                         #p"/dir/supplied-name.type")
     822  t)
     823;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
     824;; as a name)
     825(deftest sbcl.30
     826  (check-merge-pathnames (make-pathname :type "supplied-type")
     827                         #p"/dir/name.type"
     828                         #p"/dir/name.supplied-type")
     829  t)
     830;; If (pathname-directory pathname) is a list whose car is
     831;; :relative, and (pathname-directory default-pathname) is a
     832;; list, then the merged directory is [...]
     833(deftest sbcl.31
     834  (check-merge-pathnames #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee"
     835                         #p"/aaa/bbb/ccc/ddd/qqq/www")
     836  t)
     837;; except that if the resulting list contains a string or
     838;; :wild immediately followed by :back, both of them are
     839;; removed.
     840(deftest sbcl.32
     841  (check-merge-pathnames
     842   ;; "../" in a namestring is parsed as :up not :back, so MAKE-PATHNAME.
     843   (make-pathname :directory '(:relative :back "blah"))
     844   #p"/aaa/bbb/ccc/ddd/eee" #P"/aaa/bbb/ccc/blah/eee")
     845  t)
     846;; If (pathname-directory default-pathname) is not a list or
     847;; (pathname-directory pathname) is not a list whose car is
     848;; :relative, the merged directory is (or (pathname-directory
     849;; pathname) (pathname-directory default-pathname))
     850(deftest sbcl.33
     851  (check-merge-pathnames #p"/absolute/path/name" #p"/dir/default-name.type"
     852                         #P"/absolute/path/name.type")
     853  t)
     854(deftest sbcl.34
     855  (check-merge-pathnames #p"scratch:;name2" #p"scratch:foo;"
     856                         #p"SCRATCH:FOO;NAME2")
     857  t)
     858(deftest sbcl.35
     859  (check-merge-pathnames #p"scratch:;foo" #p"/usr/local/doc/"
     860                         #-(or allegro clisp) #P"SCRATCH:USR;LOCAL;DOC;FOO"
     861                         #+allegro #p"/usr/local/doc/foo"
     862                         #+clisp #p"SCRATCH:;FOO")
     863  t)
     864(deftest sbcl.36
     865  (check-merge-pathnames #p"scratch:supplied-dir;" #p"/dir/name.type"
     866                         #-clisp #p"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
     867                         #+clisp
     868                         ;; #p"SCRATCH:SUPPLIED-DIR;name.type.NEWEST"
     869                         (make-pathname :host "SCRATCH"
     870                                        :directory '(:absolute "SUPPLIED-DIR")
     871                                        :name "name"
     872                                        :type "type"))
     873  t)
     874(deftest sbcl.37
     875  (check-merge-pathnames #p"scratch:;supplied-name" #p"/dir/name.type"
     876                         #-(or allegro clisp) #p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
     877                         #+allegro #p"/usr/local/doc/supplied-name.type"
     878                         #+clisp
     879                         ;; #P"SCRATCH:;SUPPLIED-NAME.type.NEWEST"
     880                         (make-pathname :host "SCRATCH"
     881                                        :directory '(:relative)
     882                                        :name "SUPPLIED-NAME"
     883                                        :type "type"))
     884  t)
     885(deftest sbcl.38
     886  (check-merge-pathnames (make-pathname :host "scratch" :type "supplied-type")
     887                         #p"/dir/name.type"
     888                         #-(or allegro clisp) #p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
     889                         #+allegro #p"/usr/local/doc/name.supplied-type"
     890                         #+clisp
     891                         ;; #P"SCRATCH:dir;name.supplied-type.NEWEST"
     892                         (make-pathname :host "SCRATCH"
     893                                        :directory '(:absolute "dir")
     894                                        :name "name"
     895                                        :type "supplied-type"))
     896  t)
     897(deftest sbcl.39
     898  #-allegro
     899  (check-merge-pathnames (make-pathname :host "scratch"
     900                                        :directory '(:relative "foo")
     901                                        :name "bar")
     902                         #p"/aaa/bbb/ccc/ddd/eee"
     903                         #-clisp #p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
     904                         #+clisp
     905                         ;; #P"SCRATCH:;foo;bar"
     906                         (make-pathname :host "SCRATCH"
     907                                        :directory '(:relative "foo")
     908                                        :name "bar"))
     909  #+allegro
     910  (signals-error (merge-pathnames (make-pathname :host "scratch"
     911                                                 :directory '(:relative "foo")
     912                                                 :name "bar")
     913                                  #p"/aaa/bbb/ccc/ddd/eee")
     914                 'error)
     915  t)
     916(deftest sbcl.40
     917  #-allegro
     918  (check-merge-pathnames (make-pathname :host "scratch"
     919                                        :directory '(:relative :back "foo")
     920                                        :name "bar")
     921                         #p"/aaa/bbb/ccc/ddd/eee"
     922                         #-clisp #p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
     923                         #+clisp
     924                         ;; #P"SCRATCH:;..;foo;bar.NEWEST"
     925                         (make-pathname :host "SCRATCH"
     926                                        :directory '(:relative :back "foo")
     927                                        :name "bar"))
     928  #+allegro
     929  (signals-error (merge-pathnames (make-pathname :host "scratch"
     930                                                 :directory '(:relative :back "foo")
     931                                                 :name "bar")
     932                         #p"/aaa/bbb/ccc/ddd/eee")
     933                 'error)
     934  t)
     935(deftest sbcl.41
     936  (check-merge-pathnames #p"scratch:absolute;path;name"
     937                         #p"/dir/default-name.type"
     938                         #-clisp #p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
     939                         #+clisp
     940                         ;; #P"SCRATCH:ABSOLUTE;PATH;NAME.type.NEWEST"
     941                         (make-pathname :host "SCRATCH"
     942                                        :directory '(:absolute "ABSOLUTE" "PATH")
     943                                        :name "NAME"
     944                                        :type "type"))
     945  t)
     946
     947(deftest sbcl.42
    889948  (check-namestring (parse-namestring "/foo" (host-namestring #p"/bar")) "/foo")
    890949  t)
    891 (deftest sbcl.28
     950(deftest sbcl.43
    892951  (string= (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
    893952           "SCRATCH:FOO")
    894953  t)
    895954#-(or allegro clisp cmu)
    896 (deftest sbcl.29
     955(deftest sbcl.44
    897956  ;; "The null string, "", is not a valid value for any component of a logical
    898957  ;; pathname." 19.3.2.2
     
    902961  t)
    903962
    904 (rt:do-tests)
     963(do-tests)
Note: See TracChangeset for help on using the changeset viewer.