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

Last change on this file since 15778 was 15778, checked in by svspire, 8 years ago

Make (= (length (directory #P"ccl:*.*")) (length (directory #P"ccl:*")))
be true, as it was in MCL.

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