X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=d1933d614480e33bfe3f69754872cf384ffef770;hb=eaec8176060e89efa39f01017df1f6204e491ecc;hp=482b34b4fc316cf117e49738d17a41a23f3f24c8;hpb=1dc69aa156beb876b51c1ad23db73730723bce6d;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 482b34b..d1933d6 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -471,21 +471,66 @@ or if PATHSPEC is a wild pathname." (defun delete-file (file) #!+sb-doc - "Delete the specified FILE." - (let* ((truename (probe-file file)) - (namestring (when truename - (native-namestring truename :as-file t)))) + "Delete the specified FILE. + +If FILE is a stream, on Windows the stream is closed immediately. On Unix +plaforms the stream remains open, allowing IO to continue: the OS resources +associated with the deleted file remain available till the stream is closed as +per standard Unix unlink() behaviour." + (let* ((pathname (translate-logical-pathname file)) + (namestring (native-namestring pathname :as-file t))) + (truename file) ; for error-checking side-effect + #!+win32 (when (streamp file) - (close file :abort t)) - (unless namestring - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) + (close file)) (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) (unless res (simple-file-perror "couldn't delete ~A" namestring err)))) t) + +(defun delete-directory (pathspec &key recursive) + "Deletes the directory designated by PATHSPEC (a pathname designator). +Returns the truename of the directory deleted. + +If RECURSIVE is false \(the default), signals an error unless the directory is +empty. If RECURSIVE is true, first deletes all files and subdirectories. If +RECURSIVE is true and the directory contains symbolic links, the links are +deleted, not the files and directories they point to. + +Signals an error if PATHSPEC designates a file instead of a directory, or if +the directory could not be deleted for any reason. + +\(DELETE-DIRECTORY \"/tmp/foo\") and \(DELETE-DIRECTORY \"/tmp/foo/\") both +delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not +exist or is a file. + +Experimental: interface subject to change." + (declare (type pathname-designator pathspec)) + (with-pathname (pathname pathspec) + (let ((truename (truename (translate-logical-pathname pathname)))) + (labels ((recurse (dir) + (map-directory #'recurse dir + :files nil + :directories t + :classify-symlinks nil) + (map-directory #'delete-file dir + :files t + :directories nil + :classify-symlinks nil) + (delete-dir dir)) + (delete-dir (dir) + (let* ((namestring (native-namestring dir :as-file t)) + (res (alien-funcall (extern-alien #!-win32 "rmdir" + #!+win32 "_rmdir" + (function int c-string)) + namestring))) + (if (minusp res) + (simple-file-perror "Could not delete directory ~A:~% ~A" + namestring (get-errno)) + dir)))) + (if recursive + (recurse truename) + (delete-dir truename)))))) (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) @@ -497,30 +542,32 @@ or if PATHSPEC is a wild pathname." *default-pathname-defaults* :as-directory t)))) +(defun user-homedir-namestring (&optional username) + (if username + (sb!unix:user-homedir username) + (let ((env-home (posix-getenv "HOME"))) + (if (and env-home (not (string= env-home ""))) + env-home + #!-win32 + (sb!unix:uid-homedir (sb!unix:unix-getuid)))))) + ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) #!+sb-doc "Return the home directory of the user as a pathname. If the HOME environment variable has been specified, the directory it designates is returned; otherwise obtains the home directory from the operating -system." +system. HOST argument is ignored by SBCL." (declare (ignore host)) - (let ((env-home (posix-getenv "HOME"))) - (values - (parse-native-namestring - (if (and env-home (not (string= env-home ""))) - env-home - #!-win32 - (sb!unix:uid-homedir (sb!unix:unix-getuid)) - #!+win32 - ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH - ;; What?! -- RMK, 2007-12-31 - (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile))) - #!-win32 sb!impl::*unix-host* - #!+win32 sb!impl::*win32-host* - *default-pathname-defaults* - :as-directory t)))) + (values + (parse-native-namestring + (or (user-homedir-namestring) + #!+win32 + (sb!win32::get-folder-namestring sb!win32::csidl_profile)) + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t))) ;;;; DIRECTORY @@ -675,7 +722,8 @@ matching filenames." ;;; This is our core directory access interface that we use to implement ;;; DIRECTORY. -(defun map-directory (function directory &key (files t) (directories t) (errorp t)) +(defun map-directory (function directory &key (files t) (directories t) + (classify-symlinks) (errorp t)) #!+sb-doc "Map over entries in DIRECTORY. Keyword arguments specify which entries to map over, and how: @@ -690,16 +738,18 @@ map over, and how: as a file in DIRECTORY. Otherwise the pathname used is a directory pathname. Defaults to T. + :CLASSIFY-SYMLINKS + If T, the decision to call FUNCTION with the pathname of a symbolic link + depends on the resolution of the link: if it points to a directory, it is + considered a directory entry, otherwise a file entry. If false, all + symbolic links are considered file entries. Defaults to T. In both cases + the pathname used for the symbolic link is not fully resolved, but names it + as an immediate child of DIRECTORY. + :ERRORP If true, signal an error if DIRECTORY does not exist, cannot be read, etc. Defaults to T. -On platforms supporting symbolic links the decision to call FUNCTION with its -pathname depends on the resolution of the link: if it points to a directory, -it is considered a directory entry. Whether it is considered a file or a -directory, the provided pathname is not fully resolved, but rather names the -symbolic link as an immediate child of DIRECTORY. - Experimental: interface subject to change." (declare (pathname-designator directory)) (let* ((fun (%coerce-callable-to-fun function)) @@ -732,17 +782,20 @@ Experimental: interface subject to change." (when directories (map-it name t))) (:symlink - (let* ((tmpname (merge-pathnames - (parse-native-namestring - name nil physical :as-directory nil) - physical)) - (truename (query-file-system tmpname :truename nil))) - (if (or (not truename) - (or (pathname-name truename) (pathname-type truename))) - (when files - (funcall fun tmpname)) - (when directories - (map-it name t))))) + (if classify-symlinks + (let* ((tmpname (merge-pathnames + (parse-native-namestring + name nil physical :as-directory nil) + physical)) + (truename (query-file-system tmpname :truename nil))) + (if (or (not truename) + (or (pathname-name truename) (pathname-type truename))) + (when files + (funcall fun tmpname)) + (when directories + (map-it name t)))) + (when files + (map-it name nil)))) (t ;; Anything else parses as a file. (when files