common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Canonicalize :directory in MAKE-PATHNAME a little

Browse source
This commit is contained in:
Douglas Katzman 2017-05-05 15:48:53 -04:00
parent b45d28f126
commit e5e0950d63
3 changed files with 26 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -15,7 +15,10 @@ changes relative to sbcl-1.3.17:
For instance, two functions returning the literal string "HI"
might return EQ strings after collapsing, which may be undesired
in a particular use. The flag pertains to gencgc only.
* bug fix: MAKE-PATHNAME removes empty strings as components of a
directory, as is permitted: "Whenever a pathname is constructed
the components may be canonicalized if appropriate."
changes in sbcl-1.3.17 relative to sbcl-1.3.16:
* enhancement: memory overhead from the garbage collector's metadata
is reduced on 64-bit architectures; no change for 32-bit.

29
src/code/target-pathname.lisp
View file

@ -497,20 +497,29 @@ the operating system native pathname conventions."
(member :wild :wild-inferiors)))
(pop results)
(push piece results)))
((or simple-string pattern)
(push (maybe-diddle-case piece diddle-case) results))
(string
(push (maybe-diddle-case (coerce piece 'simple-string)
diddle-case) results))
((or string pattern)
(when (typep piece '(and string (not simple-array)))
(setq piece (coerce piece 'simple-string)))
;; Unix namestrings allow embedded "//" within them. Consecutive
;; slashes are treated as one, which is weird but often convenient.
;; However, preserving empty directory components:
;; - is unaesthetic
;; - makes (NAMESTRING (MAKE-PATHNAME :DIRECTORY '(:RELATIVE "" "d")))
;; visually indistinguishable from the absolute pathname "/d/"
;; - can causes a pathname equality test to return NIL
;; on semantically equivalent pathnames. This can happen for
;; other reasons, but fewer false negatives is better.
(unless (and (stringp piece) (zerop (length piece)))
(push (maybe-diddle-case piece diddle-case) results)))
(t
(error "~S is not allowed as a directory component." piece)))))
(nreverse results)))
(simple-string
`(:absolute ,(maybe-diddle-case directory diddle-case)))
(string
`(:absolute
,(maybe-diddle-case (coerce directory 'simple-string) diddle-case)))))
(cond ((zerop (length directory)) `(:absolute))
(t
(when (typep directory '(not simple-array))
(setq directory (coerce directory 'simple-string)))
`(:absolute ,(maybe-diddle-case directory diddle-case)))))))
(defun make-pathname (&key host
(device nil devp)

6
tests/filesys.test.sh
View file

@ -47,7 +47,7 @@ run_sbcl <<EOF
(in-package :cl-user)
(let* ((directory (directory "./*.*"))
(truenames (sort directory #'string< :key #'pathname-name)))
(format t "~&TRUENAMES=~S~%" truenames)
;(format t "~&TRUENAMES=~S~%" truenames)
(finish-output)
(assert (equal truenames $expected_truenames)))
(assert (equal (truename "dirlinktest") #p"$testdir/"))
@ -69,7 +69,7 @@ run_sbcl <<EOF
(in-package :cl-user)
(let* ((directory (directory "$testdir/*.*"))
(truenames (sort directory #'string< :key #'pathname-name)))
(format t "~&TRUENAMES=~S~%" truenames)
;(format t "~&TRUENAMES=~S~%" truenames)
(finish-output)
(assert (equal truenames $expected_truenames)))
(assert (equal (truename "$testdir/test-1.tmp") #p"$testdir/test-1.tmp"))
@ -336,7 +336,7 @@ run_sbcl --eval '(sb-ext:delete-directory "simple_test_subdir1")' \
(delete-directory "one" :recursive t))' \
--eval '(handler-case (delete-directory "will_fail")
(file-error ())
(:no-error (x) (sb-ext:exit :code 1)))' \
(:no-error (x) (declare (ignore x)) (sb-ext:exit :code 1)))' \
--eval '(sb-ext:exit)'
check_status_maybe_lose "delete-directory symlink" $? \
0 "ok"