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

Last change on this file since 15837 was 15837, checked in by gz, 8 years ago

Lost checkin... Fix some pathname bugs, I no longer remember which ones.

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