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