source: trunk/source/lib/pathnames.lisp @ 14334

Last change on this file since 14334 was 14334, checked in by rme, 9 years ago

Repair Windows breakage introduced in r14322. We need to use _wunlink
and _wrename since we're now using with-filename-cstrs.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 21.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001-2009 Clozure Associates
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;pathnames.lisp Pathnames for Coral Common LISP
19(in-package "CCL")
20
21(eval-when (eval compile)
22  (require 'level-2)
23  (require 'backquote)
24)
25;(defconstant $accessDenied -5000) ; put this with other errnos
26(defconstant $afpAccessDenied -5000) ; which name to use?
27
28
29
30;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
31;ANSI CL logical pathnames
32
33
34(defvar *pathname-translations-pathname*
35  (make-pathname :host "ccl" :type "pathname-translations"))
36
37(defun load-logical-pathname-translations (host)
38  ;(setq host (verify-logical-host-name host))
39  (when (not (%str-assoc host %logical-host-translations%))
40    (setf (logical-pathname-translations host)
41          (with-open-file (file (merge-pathnames (make-pathname :name host :defaults nil)
42                                                 *pathname-translations-pathname*)
43                                :element-type 'base-char)
44            (read file)))
45    T))
46
47(defun back-translate-pathname (path &optional hosts)
48  (let ((newpath (back-translate-pathname-1 path hosts)))
49    (cond ((equalp path newpath)
50           ;; (fcomp-standard-source path)
51           (namestring (pathname path)))
52          (t newpath))))
53
54
55(defun back-translate-pathname-1 (path &optional hosts)
56  (dolist (host %logical-host-translations%)
57    (when (or (null hosts) (member (car host) hosts :test 'string-equal))
58      (dolist (trans (cdr host))
59        (when (pathname-match-p path (cadr trans))
60          (let* (newpath)         
61            (setq newpath (translate-pathname path (cadr trans) (car trans) :reversible t))
62            (return-from back-translate-pathname-1 
63              (if  (equalp path newpath) path (back-translate-pathname-1 newpath hosts))))))))
64  path)
65
66
67
68; must be after back-translate-pathname
69(defun physical-pathname-p (path)
70  (let* ((path (pathname path))
71         (dir (pathname-directory path)))
72    (and dir
73         (or (not (logical-pathname-p path))
74             (not (null (memq (pathname-host path) '(nil :unspecific))))))))
75
76
77
78;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
79;File or directory Manipulations
80
81(defun unix-rename (old-name new-name)
82  (with-filename-cstrs ((old old-name)
83                        (new new-name))
84    #+windows-target
85    (#__wunlink new)
86    (let* ((res #-windows-target (#_rename old new)
87                #+windows-target (#__wrename old new)))
88      (declare (fixnum res))
89      (if (zerop res)
90        (values t nil)
91        (values nil (%get-errno))))))
92
93(defun rename-file (file new-name &key (if-exists :error))
94  "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a
95  file, then the associated file is renamed."
96  (let* ((original (truename file))
97         (original-namestring (native-translated-namestring original))
98         (new-name (merge-pathnames new-name original))
99         (new-namestring (native-translated-namestring new-name)))
100    (unless new-namestring
101      (error "~S can't be created." new-name))
102    (unless (and (probe-file new-name)
103                 (not (if-exists if-exists new-name)))
104      (multiple-value-bind (res error)
105                           (unix-rename original-namestring
106                                        new-namestring)
107        (unless res
108          (error "Failed to rename ~A to ~A: ~A"
109                 original new-name error))
110        (when (streamp file)
111          (setf (stream-filename file)
112                (namestring (native-to-pathname new-namestring))))
113        (values new-name original (truename new-name))))))
114
115(defun copy-file (source-path dest-path &key (if-exists :error) (if-does-not-exist :create)
116                              (preserve-attributes nil))
117  (let* ((original (truename source-path))
118         (new-name (merge-pathnames dest-path original))
119         (buffer (make-array 4096 :element-type '(unsigned-byte 8))))
120    (with-open-file (in original :direction :input
121                        :element-type '(unsigned-byte 8))
122      (with-open-file (out new-name :direction :output
123                           :if-exists if-exists
124                           :if-does-not-exist if-does-not-exist
125                           :element-type '(unsigned-byte 8))
126        (loop
127          as n = (stream-read-vector in buffer 0 4096) until (eql n 0)
128          do (stream-write-vector out buffer 0 n))))
129    (when preserve-attributes
130      (copy-file-attributes original new-name))
131    (values new-name original (truename new-name))))
132
133(defun recursive-copy-directory (source-path dest-path &key test (if-exists :error))
134  ;; TODO: Support :if-exists :supersede to blow away any files not in source dir
135  (assert (directoryp source-path)(source-path)
136          "source-path is not a directory in RECURSIVE-COPY-DIRECTORY")
137  (setq if-exists (require-type if-exists '(member :overwrite :error)))
138  (setq dest-path (ensure-directory-pathname dest-path))
139  (when (eq if-exists :error)
140    (when (probe-file dest-path)
141      (if-exists if-exists dest-path))
142    ;; Skip the probe-file in recursive calls, we already know it's ok.
143    (setq if-exists :overwrite))
144  (let* ((source-dir (ensure-directory-pathname source-path))
145         (pattern (make-pathname :name :wild :type :wild :defaults source-dir))
146         (source-files (directory pattern :test test :directories t :files t)))
147    (ensure-directories-exist dest-path)
148    (dolist (f source-files)
149      (when (or (null test) (funcall test f))
150        (if (directory-pathname-p f)
151            (let ((dest-file (make-pathname :name (first (last (pathname-directory f)))
152                                            :defaults dest-path)))
153              (recursive-copy-directory f dest-file :test test :if-exists if-exists))
154            (let* ((dest-file (make-pathname :name (pathname-name f)
155                                             :type (pathname-type f)
156                                             :defaults dest-path)))
157              (copy-file f dest-file :if-exists :supersede :preserve-attributes t)))))))
158
159;;; use with caution!
160;;; blows away a directory and all its contents
161(defun recursive-delete-directory (path &key (if-does-not-exist :error))
162  (setq path (ensure-directory-pathname path))
163  (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil)))
164  (when (eq if-does-not-exist :error)
165    (unless (probe-file path)
166      (if-does-not-exist if-does-not-exist path)))
167  (when (probe-file path)
168      (if (directoryp path)
169          ;; it's a directory: blow it away
170          (let* ((pattern (make-pathname :name :wild :type :wild :defaults path))
171                 (files (directory pattern :directories nil :files t))
172                 (subdirs (directory pattern :directories t :files nil))
173                 (target-pathname (native-translated-namestring path)))
174            (dolist (f files)
175              (delete-file f))
176            (dolist (d subdirs)
177              (recursive-delete-directory d :if-does-not-exist if-does-not-exist))
178            (%rmdir target-pathname))
179          ;; it's not a directory: for safety's sake, signal an error
180          (error "Pathname '~A' is not a directory" path))))
181
182;;; It's not clear that we can support anything stronger than
183;;; "advisory" ("you pretend the file's locked & I will too") file
184;;; locking under Darwin.
185
186
187
188
189(defun create-directory (path &key (mode #o777))
190  (let* ((pathname (translate-logical-pathname (merge-pathnames path)))
191         (created-p nil)
192         (parent-dirs (let* ((pd (pathname-directory pathname)))
193                        (if (eq (car pd) :relative)
194                          (pathname-directory (merge-pathnames
195                                               pathname
196                                               (mac-default-directory)))
197                          pd)))
198         (nparents (length parent-dirs)))
199    (when (wild-pathname-p pathname)
200      (error 'file-error :error-type "Inappropriate use of wild pathname ~s"
201             :pathname pathname))
202    (do* ((i 1 (1+ i)))
203         ((> i nparents) (values pathname created-p))
204      (declare (fixnum i))
205      (let* ((parent (make-pathname
206                      :name :unspecific
207                      :type :unspecific
208                      :host (pathname-host pathname)
209                      :device (pathname-device pathname)
210                      :directory (subseq parent-dirs 0 i)))
211             (parent-name (native-translated-namestring parent))
212             (parent-kind (%unix-file-kind parent-name)))
213
214        (if parent-kind
215          (unless (eq parent-kind :directory)
216            (error 'simple-file-error
217                   :error-type "Can't create directory ~s, since file ~a exists and is not a directory"
218                   :pathname pathname
219                   :format-arguments (list parent-name)))
220          (let* ((result (%mkdir parent-name mode)))
221            (declare (fixnum result))
222            (if (< result 0)
223              (signal-file-error result parent-name)
224              (setq created-p t))))))))
225
226
227(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
228  "Test whether the directories containing the specified file
229  actually exist, and attempt to create them if they do not.
230  The MODE argument is an extension to control the Unix permission
231  bits.  Portable programs should avoid using the :MODE keyword
232  argument."
233  (let ((pathname (let ((pathspec (translate-logical-pathname (merge-pathnames pathspec))))
234                    (make-directory-pathname :device (pathname-device pathspec)
235                                             :directory (pathname-directory pathspec))))
236        (created-p nil))
237    (when (wild-pathname-p pathname)
238      (error 'file-error
239             :error-type "Inappropriate use of wild pathname ~s"
240             :pathname pathname))
241    (let ((dir (pathname-directory pathname)))
242      (if (eq (car dir) :relative)
243        (setq dir (pathname-directory (merge-pathnames
244                                       pathname
245                                       (mac-default-directory)))))
246      (loop for i from 1 upto (length dir)
247            do (let ((newpath (make-pathname
248                               :name :unspecific
249                               :type :unspecific
250                               :host (pathname-host pathname)
251                               :device (pathname-device pathname)
252                               :directory (subseq dir 0 i))))
253                 (unless (probe-file newpath)
254                   (let ((namestring (native-translated-namestring newpath)))
255                     (when verbose
256                       (format *standard-output* "~&Creating directory: ~A~%"
257                               namestring))
258                     (%mkdir namestring mode)
259                     (unless (probe-file newpath)
260                       (error 'file-error
261                              :pathname namestring
262                              :error-type "Can't create directory ~S."))
263                     (setf created-p t)))))
264      (values pathspec created-p))))
265
266(defun dirpath-to-filepath (path)
267  (setq path (translate-logical-pathname (merge-pathnames path)))
268  (let* ((dir (pathname-directory path))
269         (super (butlast dir))
270         (name (car (last dir))))
271    (when (eq name :up)
272      (setq dir (remove-up (copy-list dir)))
273      (setq super (butlast dir))
274      (setq name (car (last dir))))
275    (when (null super)
276      (signal-file-error $xnocreate path))
277    (setq path (make-pathname :directory super :name name :defaults nil))))
278
279(defun filepath-to-dirpath (path)
280  (let* ((dir (pathname-directory path))
281         (rest (file-namestring path)))
282    (make-pathname :directory (append dir (list rest)) :defaults nil)))
283 
284
285
286;Takes a pathname, returns the truename of the directory if the pathname
287;names a directory, NIL if it names an ordinary file, error otherwise.
288;E.g. (directoryp "ccl;:foo:baz") might return #P"hd:mumble:foo:baz:" if baz
289;is a dir. - should we doc this - its exported?
290(defun directoryp (path)
291  (let* ((native (native-translated-namestring path))
292         (realpath (%realpath native)))
293    (if realpath (eq (%unix-file-kind realpath) :directory))))
294         
295
296;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
297;Wildcards
298
299
300
301 
302;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
303;Directory Traversing
304
305(defun %path-cat (device dir subdir)
306  (if device
307      (%str-cat device ":" dir subdir)
308    (%str-cat dir subdir)))
309
310(defmacro with-open-dir ((dirent device dir) &body body)
311  `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil)))))
312     (when ,dirent
313       (unwind-protect
314           (progn ,@body)
315         (close-dir ,dirent)))))
316
317(defun path-is-link (path)
318  "Returns T if PATH is a (hard or symbolic) link, NIL otherwise."
319  (eq (%unix-file-kind (native-translated-namestring path) t) :link))
320
321
322(defun %add-directory-result (path result follow-links)
323  (let* ((resolved (and follow-links (path-is-link path) (probe-file path))))
324    (if resolved
325      (push (namestring resolved) (cdr result)) ; may introduce duplicates.
326      (push (namestring path) (car result)))
327    path))
328
329(defun %make-directory-result ()
330  (cons nil nil))
331
332(defun %process-directory-result (result)
333  (dolist (resolved (cdr result) (mapcar #'parse-namestring (sort (car result)  #'string<)))
334    (pushnew resolved (car result) :test #'string=)))
335
336 
337(defun directory (path &key (directories nil) ;; include subdirectories
338                            (files t)         ;; include files
339                            (all t)           ;; include Unix dot files (other than dot and dot dot)
340                            (directory-pathnames t) ;; return directories as directory-pathname-p's.
341                            (include-emacs-lockfiles nil) ;; inculde .#foo
342                            test              ;; Only return pathnames matching test
343                            (follow-links t)) ;; return truename's of matching files.
344  "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
345   given pathname. Note that the interaction between this ANSI-specified
346   TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
347   means this function can sometimes return files which don't have the same
348   directory as PATHNAME."
349  (let* ((keys (list :directories directories ;list defaulted key values
350                     :files files
351                     :all all
352                     :directory-pathnames directory-pathnames
353                     :test test
354                     :include-emacs-lockfiles include-emacs-lockfiles
355                     :follow-links follow-links))
356         (path (full-pathname (merge-pathnames path) :no-error nil))
357         (dir (directory-namestring path)))
358    (declare (dynamic-extent keys))
359    (if (null (pathname-directory path))
360      (setq dir (directory-namestring (setq path
361                                            (merge-pathnames path
362                                                             (mac-default-directory))))))
363    (assert (eq (car (pathname-directory path)) :absolute) ()
364            "full-pathname returned relative path ~s??" path)
365    (%process-directory-result (%directory "/" dir path '(:absolute) keys (%make-directory-result)))))
366
367(defun %directory (dir rest path so-far keys result)
368  (multiple-value-bind (sub-dir wild rest) (%split-dir rest)
369    (%some-specific dir sub-dir wild rest path so-far keys result)))
370
371(defun %some-specific (dir sub-dir wild rest path so-far keys result)
372  (let* ((start 1)
373         (end (length sub-dir))
374         (full-dir (if (eq start end) dir (%str-cat dir (%substr sub-dir start end)))))
375    (while (neq start end)
376      (let ((pos (position #\/ sub-dir :start start :end end)))
377        (push (%path-std-quotes (%substr sub-dir start pos) nil "/:;*") so-far)
378        (setq start (%i+ 1 pos))))
379    (cond ((null wild)
380           (%files-in-directory full-dir path so-far keys result))
381          ((string= wild "**")
382           (%all-directories full-dir rest path so-far keys result))
383          (t (%one-wild full-dir wild rest path so-far keys result)))))
384
385; for a * or *x*y
386(defun %one-wild (dir wild rest path so-far keys result)
387  (let ((device (pathname-device path))
388        (all (getf keys :all))
389        name)
390    (with-open-dir (dirent device dir)
391      (while (setq name (%read-dir dirent))
392        (when (and (or all (neq (%schar name 0) #\.))
393                   (not (string= name "."))
394                   (not (string= name ".."))
395                   (%path-pstr*= wild name)
396                   (eq (%unix-file-kind (%path-cat device dir name) t) :directory))
397          (let ((subdir (%path-cat nil dir name))
398                (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
399            (declare (dynamic-extent so-far))
400            (%directory (%str-cat subdir "/") rest path so-far keys result)
401))))
402    result))
403
404(defun %files-in-directory (dir path so-far keys result)
405  (let ((device (pathname-device path))
406        (name (pathname-name path))
407        (type (pathname-type path))
408        (directories (getf keys :directories))
409        (files (getf keys :files))
410        (directory-pathnames (getf keys :directory-pathnames))
411        (test (getf keys :test))
412        (follow-links (getf keys :follow-links))
413        (all (getf keys :all))
414        (include-emacs-lockfiles (getf keys :include-emacs-lockfiles))
415        sub dir-list ans)
416    (if (not (or name type))
417      (let (full-path)
418        (when (and directories
419                   (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device)))
420                                        t)
421                       :directory))
422          (setq ans (if directory-pathnames full-path
423                      (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device)))
424          (when (and ans (or (null test) (funcall test ans)))
425            (%add-directory-result ans result follow-links))))
426      (with-open-dir (dirent (pathname-device path) dir)
427        (while (setq sub (%read-dir dirent))
428          (when (and (or all (neq (%schar sub 0) #\.))
429                     (or include-emacs-lockfiles
430                         (< (length sub) 2)
431                         (not (string= sub ".#" :end1 2)))
432                     (not (string= sub "."))
433                     (not (string= sub ".."))
434                     (%file*= name type sub))
435            (setq ans
436                  (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
437                    (when directories
438                      (let* ((std-sub (%path-std-quotes sub nil "/;:*")))
439                        (if directory-pathnames
440                          (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device)
441                          (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil nil device))))
442                    (when files
443                      (multiple-value-bind (name type) (%std-name-and-type sub)
444                        (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device)))))
445            (when (and ans (or (null test) (funcall test ans)))
446              (%add-directory-result ans result follow-links))))))
447    result))
448
449(defun %all-directories (dir rest path so-far keys result)
450  (let ((do-files nil)
451        (do-dirs nil)
452        (device (pathname-device path))
453        (name (pathname-name path))
454        (type (pathname-type path))
455        (all (getf keys :all))
456        (test (getf keys :test))
457        (directory-pathnames (getf keys :directory-pathnames))
458        (follow-links (getf keys :follow-links))
459        sub dir-list ans)
460    ;; First process the case that the ** stands for 0 components
461    (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest)
462      (while (and next-wild ; Check for **/**/ which is the same as **/
463                  (string= next-dir "/")
464                  (string= next-wild "**"))
465        (setq rest next-rest)
466        (multiple-value-setq (next-dir next-wild next-rest) (%split-dir rest)))
467      (cond ((not (string= next-dir "/"))
468             (%some-specific dir next-dir next-wild next-rest path so-far keys result))
469            (next-wild
470             (%one-wild dir next-wild next-rest path so-far keys result))
471            ((or name type)
472             (when (getf keys :files) (setq do-files t))
473             (when (getf keys :directories) (setq do-dirs t)))
474            (t (when (getf keys :directories)
475                 (setq sub (if directory-pathnames
476                             (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil device)
477                             (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device)))
478                 (when (or (null test) (funcall test sub))
479                   (%add-directory-result sub result follow-links))))))
480    ;; now descend doing %all-dirs on dirs and collecting files & dirs
481    ;; if do-x is t
482    (with-open-dir (dirent device (%path-std-quotes dir nil "*;:"))
483      (while (setq sub (%read-dir dirent))
484        (when (and (or all (neq (%schar sub 0) #\.))
485                   (not (string= sub "."))
486                   (not (string= sub "..")))
487          (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
488            (let* ((subfile (%path-cat nil dir sub))
489                   (std-sub (%path-std-quotes sub nil "/;:*"))
490                   (so-far (cons std-sub so-far))
491                   (subdir (%str-cat subfile  "/")))
492              (declare (dynamic-extent so-far))
493              (when (and do-dirs (%file*= name type sub))
494                (setq ans (if directory-pathnames
495                            (%cons-pathname (reverse so-far) nil nil nil device)
496                            (%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far))))
497                                            std-sub nil nil device)))
498                (when (or (null test) (funcall test ans))
499                  (%add-directory-result ans result follow-links)))
500              (%all-directories subdir rest path so-far keys result))
501            (when (and do-files (%file*= name type sub))
502              (multiple-value-bind (name type) (%std-name-and-type sub)
503                (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device))
504                (when (or (null test) (funcall test ans))
505                  (%add-directory-result ans result follow-links))))))))
506    result))
507
508(defun %split-dir (dir &aux pos)                 ; dir ends in a "/".
509  ;"/foo/bar/../x*y/baz/../z*t/"  ->  "/foo/bar/../" "x*y" "/baz/../z*t/"
510  (if (null (setq pos (%path-mem "*" dir)))
511    (values dir nil nil)
512    (let (epos (len (length dir)))
513      (setq pos (if (setq pos (%path-mem-last "/" dir 0 pos)) (%i+ pos 1) 0)
514            epos (%path-mem "/" dir pos len))
515      (when (%path-mem-last-quoted "/" dir 0 pos)
516        (signal-file-error $xbadfilenamechar dir #\/))
517      (values (unless (%izerop pos) (namestring-unquote (%substr dir 0 pos)))
518              (%substr dir pos epos)
519              (%substr dir epos len)))))
520
521(defun %path-pstr*= (pattern pstr &optional (p-start 0))
522  (assert (eq p-start 0))
523  (%path-str*= pstr pattern))
524
525(defun %file*= (name-pat type-pat pstr)
526  (if (eq name-pat :wild) (setq name-pat "*"))
527  (if (eq type-pat :wild) (setq type-pat "*"))
528  (when (and (null name-pat) (null type-pat))
529    (return-from %file*= T))
530  (let* ((end (length pstr))
531         (pos (position #\. pstr :from-end t))
532         (type (and pos (%substr pstr (%i+ pos 1) end)))
533         (name (unless (eq (or pos end) 0) (if pos (%substr pstr 0 pos) pstr))))
534    (and (cond ((or (eq name-pat :unspecific) (null name-pat)) (null name))
535               (t (%path-pstr*= name-pat (or name ""))))
536         (cond ((or (null type-pat) (eq type-pat :unspecific)) (null type))
537               (t (%path-pstr*= type-pat (or type "")))))))
538
539(provide "PATHNAMES")
Note: See TracBrowser for help on using the repository browser.