[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] master: Fix handling of name and type components in DIRECTORIZE-PATHNAME
From: Jan Moringen via Sbcl-commits <sbcl-commits () lists ! sourceforge ! net>
Date: 2017-12-31 20:08:00
Message-ID: 1514750881.118269.421 () sfp-scm-3 ! v30 ! ch3 ! sourceforge ! com
[Download RAW message or body]
The branch "master" has been updated in SBCL:
via 179bc57a9c8f4ada9f23a273d9f936e12733fd94 (commit)
from 1e9551821d614ef415f083921be46367ed920734 (commit)
- Log -----------------------------------------------------------------
commit 179bc57a9c8f4ada9f23a273d9f936e12733fd94
Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Sun Dec 31 19:41:16 2017 +0100
Fix handling of name and type components in DIRECTORIZE-PATHNAME
Previously, when encountering a PATHNAME with name or type components,
DIRECTORIZE-PATHNAME unparsed those via FILE-NAMESTRING and stuck that
namestring into the directory component of the result. The problem was
that the directory component is not supposed to contain
namestrings. This makes a difference when the original name or type
components contain characters that get escaped in the namestring:
(pathname-directory (directorize-pathname (merge-pathnames "a\\*b" "/")))
=> (:ABSOLUTE "a\\*b") but should be (:ABSOLUTE "a*b")
Based on initial analyses by Richard M. Kreuter.
fixes lp#1740624
---
NEWS | 3 ++
src/code/filesys.lisp | 98 +++++++++++++++++++++++++++----------------------
tests/filesys.pure.lisp | 25 +++++++++++++
3 files changed, 82 insertions(+), 44 deletions(-)
diff --git a/NEWS b/NEWS
index ad6bc14..2c468f3 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,9 @@ changes relative to sbcl-1.4.3:
*DEFAULT-PATHNAME-DEFAULTS* has a name or type component. (lp#1740563)
* bug fix: pattern pieces in pathname components are correctly escaped
during unparsing
+ * bug fix: DELETE-DIRECTORY no longer signals an error when the directory is
+ supplied as a pathname with name and/or type components containing escaped
+ characters. (lp#1740624)
changes in sbcl-1.4.3 relative to sbcl-1.4.2:
* enhancement: SLEEP respects deadlines established by SB-SYS:WITH-DEADLINE.
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index cc22d4b..537b81f 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -538,13 +538,23 @@ per standard Unix unlink() behaviour."
t)
(defun directorize-pathname (pathname)
- (if (or (pathname-name pathname)
- (pathname-type pathname))
- (make-pathname :directory (append (pathname-directory pathname)
- (list (file-namestring pathname)))
- :host (pathname-host pathname)
- :device (pathname-device pathname))
+ (cond
+ ((wild-pathname-p pathname)
+ (simple-file-perror
+ "Cannot compute directory pathname for wild pathname ~S"
pathname))
+ ((or (pathname-name pathname)
+ (pathname-type pathname))
+ (let ((from-file (format nil "~@[~A~]~@[.~A~]"
+ (pathname-name pathname)
+ (pathname-type pathname))))
+ (make-pathname
+ :host (pathname-host pathname)
+ :device (pathname-device pathname)
+ :directory (append (pathname-directory pathname)
+ (list from-file)))))
+ (t
+ pathname)))
(defun delete-directory (pathspec &key recursive)
"Deletes the directory designated by PATHSPEC (a pathname designator).
@@ -566,44 +576,44 @@ Both
delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not
exist or if is a file or a symbolic link."
(declare (type pathname-designator pathspec))
- (let ((physical (directorize-pathname
- (physicalize-pathname
- (merge-pathnames
- pathspec (sane-default-pathname-defaults))))))
- (labels ((recurse-merged (dir)
- (lambda (sub)
- (recurse (merge-pathnames sub dir))))
- (delete-merged (dir)
- (lambda (file)
- (delete-file (merge-pathnames file dir))))
- (recurse (dir)
- (map-directory (recurse-merged dir) dir
- :files nil
- :directories t
- :classify-symlinks nil)
- (map-directory (delete-merged dir) dir
- :files t
- :directories nil
- :classify-symlinks nil)
- (delete-dir dir))
- (delete-dir (dir)
- (let ((namestring (native-namestring dir :as-file t)))
- (multiple-value-bind (res errno)
- #!+win32
- (or (sb!win32::native-delete-directory namestring)
- (values nil (sb!win32:get-last-error)))
- #!-win32
- (values
- (not (minusp (alien-funcall
- (extern-alien "rmdir"
- (function int c-string))
- namestring)))
- (get-errno))
- (if res
- dir
- (simple-file-perror
- "Could not delete directory ~A"
- namestring errno))))))
+ (labels ((recurse-merged (dir)
+ (lambda (sub)
+ (recurse (merge-pathnames sub dir))))
+ (delete-merged (dir)
+ (lambda (file)
+ (delete-file (merge-pathnames file dir))))
+ (recurse (dir)
+ (map-directory (recurse-merged dir) dir
+ :files nil
+ :directories t
+ :classify-symlinks nil)
+ (map-directory (delete-merged dir) dir
+ :files t
+ :directories nil
+ :classify-symlinks nil)
+ (delete-dir dir))
+ (delete-dir (dir)
+ (let ((namestring (native-namestring dir :as-file t)))
+ (multiple-value-bind (res errno)
+ #!+win32
+ (or (sb!win32::native-delete-directory namestring)
+ (values nil (sb!win32:get-last-error)))
+ #!-win32
+ (values
+ (not (minusp (alien-funcall
+ (extern-alien "rmdir"
+ (function int c-string))
+ namestring)))
+ (get-errno))
+ (if res
+ dir
+ (simple-file-perror
+ "Could not delete directory ~A"
+ namestring errno))))))
+ (let ((physical (directorize-pathname
+ (physicalize-pathname
+ (merge-pathnames
+ pathspec (sane-default-pathname-defaults))))))
(if recursive
(recurse physical)
(delete-dir physical)))))
diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp
index 06ec118..e4ffaff 100644
--- a/tests/filesys.pure.lisp
+++ b/tests/filesys.pure.lisp
@@ -319,3 +319,28 @@
(with-test (:name :parse-native-namestring-canon :skipped-on (not :unix))
(let ((pathname (parse-native-namestring "foo/bar//baz")))
(assert (string= (car (last (pathname-directory pathname))) "bar"))))
+
+
+;;;; DELETE-DIRECTORY
+
+(with-test (:name (delete-directory :as-file :complicated-name-or-type :lp-1740624))
+ (labels ((prepare (namestring)
+ #-win32 (substitute #\\ #\E namestring)
+ #+win32 (substitute #\^ #\E namestring))
+ (test (namestring/file namestring/directory)
+ (let* ((test-directory (concatenate
+ 'string
+ (sb-posix:getenv "TEST_DIRECTORY") "/"))
+ (delete-directory (merge-pathnames
+ (prepare namestring/file)
+ test-directory)))
+ (ensure-directories-exist (merge-pathnames
+ (prepare namestring/directory)
+ test-directory))
+ (unwind-protect
+ (progn
+ (delete-directory delete-directory)
+ (assert (not (probe-file delete-directory))))
+ (delete-directory test-directory :recursive t)))))
+ (test "aE*b" "aE*b/")
+ (test "foo.aE*b" "foo.aE*b/")))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
------------------------------------------------------------------------------
Check out the vibrant tech community on one of the world's most
engaging tech sites, Slashdot.org! http://sdm.link/slashdot
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic