/[cmucl]/src/code/filesys.lisp
ViewVC logotype

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.91 - (hide annotations)
Thu Sep 22 20:27:16 2005 UTC (8 years, 6 months ago) by rtoy
Branch: MAIN
Changes since 1.90: +56 -53 lines
ENOUGH-NAMESTRING did not work with search-lists.  Now just look at
the first path in a search-list to determine the appropriate
namestring.  This is mostly intended to work with the "home:"
search-list, which only has one path, by default.
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;; **********************************************************************
3 ram 1.8 ;;; This code was written as part of the CMU Common Lisp project at
4     ;;; Carnegie Mellon University, and has been placed in the public domain.
5     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
6     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
7     ;;;
8     (ext:file-comment
9 rtoy 1.91 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/filesys.lisp,v 1.91 2005/09/22 20:27:16 rtoy Exp $")
10 ram 1.8 ;;;
11 ram 1.1 ;;; **********************************************************************
12     ;;;
13 wlott 1.16 ;;; File system interface functions. This file is pretty UNIX specific.
14 ram 1.1 ;;;
15 wlott 1.16 ;;; Written by William Lott
16 ram 1.1 ;;;
17     ;;; **********************************************************************
18 ram 1.2
19     (in-package "LISP")
20    
21 wlott 1.16 (export '(truename probe-file user-homedir-pathname directory
22     rename-file delete-file file-write-date file-author))
23 ram 1.1
24     (use-package "EXTENSIONS")
25    
26     (in-package "EXTENSIONS")
27     (export '(print-directory complete-file ambiguous-files default-directory
28 toy 1.75 purge-backup-files file-writable unix-namestring))
29 ram 1.2 (in-package "LISP")
30 ram 1.1
31 wlott 1.5
32 wlott 1.16 ;;;; Unix pathname host support.
33 ram 1.1
34 wlott 1.16 ;;; Unix namestrings have the following format:
35     ;;;
36     ;;; namestring := [ directory ] [ file [ type [ version ]]]
37     ;;; directory := [ "/" | search-list ] { file "/" }*
38     ;;; search-list := [^:/]*:
39     ;;; file := [^/]*
40     ;;; type := "." [^/.]*
41 pw 1.62 ;;; version := ".*" | ".~" ([0-9]+ | "*") "~"
42 wlott 1.16 ;;;
43 toy 1.73 ;;; Note: this grammar is ambiguous. The string foo.bar.~5~ can be parsed
44 wlott 1.16 ;;; as either just the file specified or as specifying the file, type, and
45     ;;; version. Therefore, we use the following rules when confronted with
46     ;;; an ambiguous file.type.version string:
47     ;;;
48     ;;; - If the first character is a dot, it's part of the file. It is not
49     ;;; considered a dot in the following rules.
50     ;;;
51 toy 1.73 ;;; - If there is only one dot, it separates the file and the type.
52 wlott 1.16 ;;;
53     ;;; - If there are multiple dots and the stuff following the last dot
54     ;;; is a valid version, then that is the version and the stuff between
55     ;;; the second to last dot and the last dot is the type.
56     ;;;
57     ;;; Wildcard characters:
58     ;;;
59     ;;; If the directory, file, type components contain any of the following
60     ;;; characters, it is considered part of a wildcard pattern and has the
61     ;;; following meaning.
62     ;;;
63     ;;; ? - matches any character
64     ;;; * - matches any zero or more characters.
65     ;;; [abc] - matches any of a, b, or c.
66     ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
67     ;;;
68 toy 1.73 ;;; Any of these special characters can be preceded by a backslash to
69 wlott 1.16 ;;; cause it to be treated as a regular character.
70     ;;;
71 ram 1.1
72 wlott 1.16 (defun remove-backslashes (namestr start end)
73 toy 1.73 "Remove any occurrences of \\ from the string because we've already
74     checked for whatever may have been backslashed."
75 wlott 1.16 (declare (type simple-base-string namestr)
76     (type index start end))
77     (let* ((result (make-string (- end start)))
78     (dst 0)
79     (quoted nil))
80     (do ((src start (1+ src)))
81     ((= src end))
82     (cond (quoted
83     (setf (schar result dst) (schar namestr src))
84     (setf quoted nil)
85     (incf dst))
86     (t
87     (let ((char (schar namestr src)))
88     (cond ((char= char #\\)
89     (setq quoted t))
90     (t
91     (setf (schar result dst) char)
92     (incf dst)))))))
93     (when quoted
94     (error 'namestring-parse-error
95     :complaint "Backslash in bad place."
96     :namestring namestr
97     :offset (1- end)))
98     (shrink-vector result dst)))
99 ram 1.1
100 wlott 1.16 (defvar *ignore-wildcards* nil)
101 ram 1.1
102 wlott 1.16 (defun maybe-make-pattern (namestr start end)
103     (declare (type simple-base-string namestr)
104     (type index start end))
105     (if *ignore-wildcards*
106     (subseq namestr start end)
107     (collect ((pattern))
108     (let ((quoted nil)
109     (any-quotes nil)
110     (last-regular-char nil)
111     (index start))
112     (flet ((flush-pending-regulars ()
113     (when last-regular-char
114     (pattern (if any-quotes
115     (remove-backslashes namestr
116     last-regular-char
117     index)
118     (subseq namestr last-regular-char index)))
119     (setf any-quotes nil)
120     (setf last-regular-char nil))))
121     (loop
122     (when (>= index end)
123     (return))
124     (let ((char (schar namestr index)))
125     (cond (quoted
126     (incf index)
127     (setf quoted nil))
128     ((char= char #\\)
129     (setf quoted t)
130     (setf any-quotes t)
131     (unless last-regular-char
132     (setf last-regular-char index))
133     (incf index))
134     ((char= char #\?)
135     (flush-pending-regulars)
136     (pattern :single-char-wild)
137     (incf index))
138     ((char= char #\*)
139     (flush-pending-regulars)
140     (pattern :multi-char-wild)
141     (incf index))
142     ((char= char #\[)
143     (flush-pending-regulars)
144     (let ((close-bracket
145     (position #\] namestr :start index :end end)))
146     (unless close-bracket
147     (error 'namestring-parse-error
148     :complaint "``['' with no corresponding ``]''"
149     :namestring namestr
150     :offset index))
151     (pattern (list :character-set
152     (subseq namestr
153     (1+ index)
154     close-bracket)))
155     (setf index (1+ close-bracket))))
156     (t
157     (unless last-regular-char
158     (setf last-regular-char index))
159     (incf index)))))
160     (flush-pending-regulars)))
161     (cond ((null (pattern))
162     "")
163 ram 1.31 ((null (cdr (pattern)))
164     (let ((piece (first (pattern))))
165     (typecase piece
166     ((member :multi-char-wild) :wild)
167     (simple-string piece)
168     (t
169     (make-pattern (pattern))))))
170 wlott 1.16 (t
171     (make-pattern (pattern)))))))
172 ram 1.1
173 dtc 1.59 ;;; extract-name-type-and-version -- Internal.
174     ;;;
175 wlott 1.16 (defun extract-name-type-and-version (namestr start end)
176     (declare (type simple-base-string namestr)
177     (type index start end))
178 pw 1.62 (labels
179     ((explicit-version (namestr start end)
180 rtoy 1.82 ;; Look for something like "~*~" at the end of the
181     ;; namestring, where * can be #\* or some digits. This
182     ;; denotes a version.
183     (cond ((or (< (- end start) 4)
184 rtoy 1.84 (and (char/= (schar namestr (1- end)) #\~)
185     (char/= (schar namestr (1- end)) #\*)))
186 toy 1.74 ;; No explicit version given, so return NIL to
187     ;; indicate we don't want file versions, unless
188     ;; requested in other ways.
189     (values nil end))
190 rtoy 1.84 ((and (not *ignore-wildcards*)
191     (char= (schar namestr (- end 2)) #\*)
192 pw 1.62 (char= (schar namestr (- end 3)) #\~)
193     (char= (schar namestr (- end 4)) #\.))
194 rtoy 1.82 ;; Found "~*~", so it's a wild version
195 pw 1.62 (values :wild (- end 4)))
196     (t
197 rtoy 1.82 ;; Look for a version number. Start at the end, just
198     ;; before the ~ and keep looking for digits. If the
199     ;; first non-digit is ~, we have a version number, so
200     ;; get it. If not, we didn't find a version number,
201     ;; so we call it :newest
202 pw 1.62 (do ((i (- end 2) (1- i)))
203 rtoy 1.82 ((< i (+ start 1)) (values :newest end))
204 pw 1.62 (let ((char (schar namestr i)))
205     (when (eql char #\~)
206     (return (if (char= (schar namestr (1- i)) #\.)
207     (values (parse-integer namestr :start (1+ i)
208     :end (1- end))
209     (1- i))
210     (values :newest end))))
211     (unless (char<= #\0 char #\9)
212     (return (values :newest end))))))))
213     (any-version (namestr start end)
214     ;; process end of string looking for a version candidate.
215     (multiple-value-bind (version where)
216 toy 1.73 (explicit-version namestr start end)
217 pw 1.62 (cond ((not (eq version :newest))
218     (values version where))
219 rtoy 1.84 ((and (not *ignore-wildcards*)
220     (>= (- end 2) start)
221 pmai 1.65 (char= (schar namestr (- end 1)) #\*)
222 pw 1.62 (char= (schar namestr (- end 2)) #\.)
223 pw 1.63 (find #\. namestr
224     :start (min (1+ start) (- end 2))
225     :end (- end 2)))
226 pw 1.62 (values :wild (- end 2)))
227     (t (values version where)))))
228     (any-type (namestr start end)
229 pw 1.63 ;; Process end of string looking for a type. A leading "."
230     ;; is part of the name.
231     (let ((where (position #\. namestr
232     :start (min (1+ start) end)
233     :end end :from-end t)))
234 pw 1.62 (when where
235     (values where end))))
236     (any-name (namestr start end)
237     (declare (ignore namestr))
238     (values start end)))
239 toy 1.73 (multiple-value-bind (version vstart)
240     (any-version namestr start end)
241     (multiple-value-bind (tstart tend)
242     (any-type namestr start vstart)
243     (multiple-value-bind (nstart nend)
244     (any-name namestr start (or tstart vstart))
245 pw 1.62 (values
246     (maybe-make-pattern namestr nstart nend)
247     (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
248     version))))))
249 ram 1.1
250 ram 1.31 ;;; Take a string and return a list of cons cells that mark the char
251     ;;; separated subseq. The first value t if absolute directories location.
252     ;;;
253     (defun split-at-slashes (namestr start end)
254     (declare (type simple-base-string namestr)
255 wlott 1.16 (type index start end))
256     (let ((absolute (and (/= start end)
257 ram 1.31 (char= (schar namestr start) #\/))))
258 wlott 1.16 (when absolute
259     (incf start))
260 toy 1.73 ;; Next, split the remainder into slash separated chunks.
261 wlott 1.16 (collect ((pieces))
262     (loop
263 ram 1.31 (let ((slash (position #\/ namestr :start start :end end)))
264     (pieces (cons start (or slash end)))
265     (unless slash
266 wlott 1.16 (return))
267 ram 1.31 (setf start (1+ slash))))
268 wlott 1.16 (values absolute (pieces)))))
269 ram 1.1
270 wlott 1.16 (defun maybe-extract-search-list (namestr start end)
271     (declare (type simple-base-string namestr)
272     (type index start end))
273     (let ((quoted nil))
274     (do ((index start (1+ index)))
275     ((= index end)
276     (values nil start))
277     (if quoted
278     (setf quoted nil)
279     (case (schar namestr index)
280     (#\\
281     (setf quoted t))
282     (#\:
283     (return (values (remove-backslashes namestr start index)
284     (1+ index)))))))))
285 ram 1.1
286 wlott 1.16 (defun parse-unix-namestring (namestr start end)
287     (declare (type simple-base-string namestr)
288     (type index start end))
289     (multiple-value-bind
290     (absolute pieces)
291     (split-at-slashes namestr start end)
292     (let ((search-list
293     (if absolute
294     nil
295     (let ((first (car pieces)))
296     (multiple-value-bind
297 toy 1.73 (search-list new-start)
298 wlott 1.16 (maybe-extract-search-list namestr
299     (car first) (cdr first))
300     (when search-list
301     (setf absolute t)
302     (setf (car first) new-start))
303     search-list)))))
304 rtoy 1.90 (multiple-value-bind (name type version)
305 wlott 1.16 (let* ((tail (car (last pieces)))
306     (tail-start (car tail))
307     (tail-end (cdr tail)))
308     (unless (= tail-start tail-end)
309     (setf pieces (butlast pieces))
310 rtoy 1.90 (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
311     ;; ".." is a directory. Add this piece to the
312     ;; list of pieces, and make the name/type/version
313     ;; nil.
314     (setf pieces (append pieces (list (cons tail-start tail-end))))
315     (values nil nil nil))
316     ((not (find-if-not #'(lambda (c)
317     (char= c #\.))
318     namestr :start tail-start :end tail-end))
319     ;; Got a bunch of dots. Make it a file of the same name, and type nil.
320     (values (subseq namestr tail-start tail-end) nil nil))
321     (t
322     (extract-name-type-and-version namestr tail-start tail-end)))))
323 dtc 1.54 ;; PVE: Make sure there are no illegal characters in the name
324     ;; such as #\Null and #\/.
325     (when (and (stringp name)
326     (find-if #'(lambda (x)
327     (or (char= x #\Null) (char= x #\/)))
328     name))
329     (error 'parse-error))
330 wlott 1.16 ;; Now we have everything we want. So return it.
331     (values nil ; no host for unix namestrings.
332     nil ; no devices for unix namestrings.
333     (collect ((dirs))
334     (when search-list
335     (dirs (intern-search-list search-list)))
336     (dolist (piece pieces)
337     (let ((piece-start (car piece))
338     (piece-end (cdr piece)))
339     (unless (= piece-start piece-end)
340 ram 1.31 (cond ((string= namestr ".." :start1 piece-start
341     :end1 piece-end)
342     (dirs :up))
343     ((string= namestr "**" :start1 piece-start
344     :end1 piece-end)
345     (dirs :wild-inferiors))
346     (t
347     (dirs (maybe-make-pattern namestr
348     piece-start
349     piece-end)))))))
350 wlott 1.25 (cond (absolute
351     (cons :absolute (dirs)))
352     ((dirs)
353 rtoy 1.89 ;; "." in a :relative directory is the same
354     ;; as if it weren't there, so remove them.
355     (cons :relative (delete "." (dirs) :test #'equal)))
356 wlott 1.25 (t
357 rtoy 1.89 ;; If there is no directory and the name is
358     ;; ".", we really got directory ".", so make it so.
359     (if (equal name ".")
360     (list :relative)
361     nil))))
362     ;; A file with name "." can't be the name of file on
363     ;; Unix because it's a directory. This was handled
364     ;; above, so we can just set the name to nil.
365     (if (equal name ".")
366     nil
367     name)
368 wlott 1.16 type
369     version)))))
370 ram 1.1
371 wlott 1.16 (defun unparse-unix-host (pathname)
372     (declare (type pathname pathname)
373     (ignore pathname))
374 toy 1.69 ;; this host designator needs to be recognized as a physical host in
375     ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
376     ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
377     "")
378 ram 1.1
379 wlott 1.16 (defun unparse-unix-piece (thing)
380     (etypecase thing
381 ram 1.31 ((member :wild) "*")
382 rtoy 1.86 ((member :unspecific)
383     ;; CLHS 19.2.2.2.3.1 says "That is, both nil and :unspecific
384     ;; cause the component not to appear in the namestring."
385     "")
386 wlott 1.16 (simple-string
387     (let* ((srclen (length thing))
388     (dstlen srclen))
389     (dotimes (i srclen)
390     (case (schar thing i)
391     ((#\* #\? #\[)
392     (incf dstlen))))
393     (let ((result (make-string dstlen))
394     (dst 0))
395     (dotimes (src srclen)
396     (let ((char (schar thing src)))
397     (case char
398     ((#\* #\? #\[)
399     (setf (schar result dst) #\\)
400     (incf dst)))
401     (setf (schar result dst) char)
402     (incf dst)))
403     result)))
404     (pattern
405     (collect ((strings))
406     (dolist (piece (pattern-pieces thing))
407     (etypecase piece
408     (simple-string
409     (strings piece))
410     (symbol
411 ram 1.31 (ecase piece
412 wlott 1.16 (:multi-char-wild
413     (strings "*"))
414     (:single-char-wild
415 ram 1.31 (strings "?"))))
416 wlott 1.16 (cons
417     (case (car piece)
418     (:character-set
419     (strings "[")
420 rtoy 1.81 (strings (second piece))
421 wlott 1.16 (strings "]"))
422     (t
423     (error "Invalid pattern piece: ~S" piece))))))
424     (apply #'concatenate
425     'simple-string
426     (strings))))))
427 ram 1.1
428 wlott 1.16 (defun unparse-unix-directory-list (directory)
429     (declare (type list directory))
430     (collect ((pieces))
431     (when directory
432     (ecase (pop directory)
433     (:absolute
434     (cond ((search-list-p (car directory))
435     (pieces (search-list-name (pop directory)))
436     (pieces ":"))
437     (t
438     (pieces "/"))))
439     (:relative
440 rtoy 1.89 ;; Nothing special, except if we were given '(:relative).
441     (unless directory
442     (pieces "./"))
443 wlott 1.16 ))
444     (dolist (dir directory)
445     (typecase dir
446     ((member :up)
447     (pieces "../"))
448     ((member :back)
449     (error ":BACK cannot be represented in namestrings."))
450 ram 1.31 ((member :wild-inferiors)
451     (pieces "**/"))
452 rtoy 1.85 ((or simple-string pattern (eql :wild))
453 wlott 1.16 (pieces (unparse-unix-piece dir))
454     (pieces "/"))
455     (t
456     (error "Invalid directory component: ~S" dir)))))
457     (apply #'concatenate 'simple-string (pieces))))
458 ram 1.1
459 wlott 1.16 (defun unparse-unix-directory (pathname)
460     (declare (type pathname pathname))
461     (unparse-unix-directory-list (%pathname-directory pathname)))
462 toy 1.64
463 wlott 1.16 (defun unparse-unix-file (pathname)
464     (declare (type pathname pathname))
465     (collect ((strings))
466     (let* ((name (%pathname-name pathname))
467     (type (%pathname-type pathname))
468     (type-supplied (not (or (null type) (eq type :unspecific))))
469 toy 1.64 (logical-p (logical-pathname-p pathname))
470 wlott 1.16 (version (%pathname-version pathname))
471 toy 1.73 (version-supplied (not (or (null version)
472     (member version '(:newest
473     :unspecific))))))
474 wlott 1.16 (when name
475     (strings (unparse-unix-piece name)))
476     (when type-supplied
477     (unless name
478     (error "Cannot specify the type without a file: ~S" pathname))
479     (strings ".")
480     (strings (unparse-unix-piece type)))
481 rtoy 1.83 #+(or)
482 rtoy 1.82 (when (and version (not name))
483     ;; We don't want version without a name, because when we try
484     ;; to read #p".~*~" back, the name is "", not NIL.
485     (error "Cannot specify a version without a file: ~S" pathname))
486 wlott 1.16 (when version-supplied
487     (strings (if (eq version :wild)
488 toy 1.64 (if logical-p ".*" ".~*~")
489     (format nil (if logical-p ".~D" ".~~~D~~")
490     version)))))
491 pw 1.55 (and (strings) (apply #'concatenate 'simple-string (strings)))))
492 ram 1.1
493 wlott 1.16 (defun unparse-unix-namestring (pathname)
494     (declare (type pathname pathname))
495     (concatenate 'simple-string
496     (unparse-unix-directory pathname)
497     (unparse-unix-file pathname)))
498 ram 1.1
499 wlott 1.16 (defun unparse-unix-enough (pathname defaults)
500     (declare (type pathname pathname defaults))
501     (flet ((lose ()
502     (error "~S cannot be represented relative to ~S"
503     pathname defaults)))
504 rtoy 1.91 ;; Only the first path in a search-list is considered.
505     (enumerate-search-list (pathname pathname)
506     (enumerate-search-list (defaults defaults)
507     (collect ((strings))
508     (let* ((pathname-directory (%pathname-directory pathname))
509     (defaults-directory (%pathname-directory defaults))
510     (prefix-len (length defaults-directory))
511     (result-dir
512     (cond ((null pathname-directory)
513     ;; No directory, so relative to default.
514     (list :relative))
515     ((eq (first pathname-directory) :relative)
516     ;; Relative directory so relative to default.
517     pathname-directory)
518     ((and (>= prefix-len 1)
519 toy 1.72 (>= (length pathname-directory) prefix-len)
520     (compare-component (subseq pathname-directory
521     0 prefix-len)
522     defaults-directory))
523 rtoy 1.91 ;; Pathname starts with a prefix of default. So just
524     ;; use a relative directory from then on out.
525     (cons :relative (nthcdr prefix-len pathname-directory)))
526     ((eq (car pathname-directory) :absolute)
527     ;; We are an absolute pathname, so we can just use it.
528     pathname-directory)
529     (t
530     ;; We are a relative directory. So we lose.
531     (lose)))))
532     (strings (unparse-unix-directory-list result-dir)))
533     (let* ((pathname-version (%pathname-version pathname))
534     (version-needed (and pathname-version
535     (not (eq pathname-version :newest))))
536     (pathname-type (%pathname-type pathname))
537     (type-needed (or version-needed
538     (and pathname-type
539     (not (eq pathname-type :unspecific)))))
540     (pathname-name (%pathname-name pathname))
541     (name-needed (or type-needed
542     (and pathname-name
543     (not (compare-component pathname-name
544     (%pathname-name
545     defaults)))))))
546     (when name-needed
547     (unless pathname-name (lose))
548     (strings (unparse-unix-piece pathname-name)))
549     (when type-needed
550     (when (or (null pathname-type) (eq pathname-type :unspecific))
551     (lose))
552     (strings ".")
553     (strings (unparse-unix-piece pathname-type)))
554     (when version-needed
555     (typecase pathname-version
556     ((member :wild)
557     (strings ".~*~"))
558     (integer
559     (strings (format nil ".~~~D~~" pathname-version)))
560     (t
561     (lose)))))
562     (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings))))))))
563 ram 1.1
564    
565 wlott 1.16 (defstruct (unix-host
566     (:include host
567     (:parse #'parse-unix-namestring)
568     (:unparse #'unparse-unix-namestring)
569     (:unparse-host #'unparse-unix-host)
570     (:unparse-directory #'unparse-unix-directory)
571     (:unparse-file #'unparse-unix-file)
572     (:unparse-enough #'unparse-unix-enough)
573     (:customary-case :lower))
574     (:make-load-form-fun make-unix-host-load-form))
575     )
576 ram 1.1
577 wlott 1.16 (defvar *unix-host* (make-unix-host))
578 ram 1.1
579 wlott 1.16 (defun make-unix-host-load-form (host)
580     (declare (ignore host))
581     '*unix-host*)
582 ram 1.1
583 wlott 1.16
584     ;;;; Wildcard matching stuff.
585 ram 1.1
586 wlott 1.16 (defmacro enumerate-matches ((var pathname &optional result
587 dtc 1.57 &key (verify-existance t) (follow-links t))
588 wlott 1.16 &body body)
589     (let ((body-name (gensym)))
590     `(block nil
591     (flet ((,body-name (,var)
592     ,@body))
593     (%enumerate-matches (pathname ,pathname)
594 dtc 1.57 ,verify-existance ,follow-links
595 wlott 1.16 #',body-name)
596     ,result))))
597 ram 1.1
598 dtc 1.57 (defun %enumerate-matches (pathname verify-existance follow-links function)
599 ram 1.34 (when (pathname-type pathname)
600     (unless (pathname-name pathname)
601     (error "Cannot supply a type without a name:~% ~S" pathname)))
602     (let ((directory (pathname-directory pathname)))
603     (if directory
604     (ecase (car directory)
605     (:absolute
606     (%enumerate-directories "/" (cdr directory) pathname
607 dtc 1.57 verify-existance follow-links
608     nil function))
609 ram 1.34 (:relative
610     (%enumerate-directories "" (cdr directory) pathname
611 dtc 1.57 verify-existance follow-links
612     nil function)))
613 ram 1.34 (%enumerate-files "" pathname verify-existance function))))
614 ram 1.1
615 dtc 1.57 ;;; %enumerate-directories -- Internal
616     ;;;
617     ;;; The directory node and device numbers are maintained for the current path
618 toy 1.73 ;;; during the search for the detection of path loops upon :wild-inferiors.
619 dtc 1.57 ;;;
620     (defun %enumerate-directories (head tail pathname verify-existance
621     follow-links nodes function)
622 ram 1.37 (declare (simple-string head))
623 dtc 1.57 (macrolet ((unix-xstat (name)
624     `(if follow-links
625     (unix:unix-stat ,name)
626     (unix:unix-lstat ,name)))
627     (with-directory-node-noted ((head) &body body)
628     `(multiple-value-bind (res dev ino mode)
629     (unix-xstat ,head)
630     (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
631     (let ((nodes (cons (cons dev ino) nodes)))
632     ,@body))))
633     (do-directory-entries ((name directory) &body body)
634     `(let ((dir (unix:open-dir ,directory)))
635     (when dir
636     (unwind-protect
637     (loop
638     (let ((,name (unix:read-dir dir)))
639     (cond ((null ,name)
640     (return))
641     ((string= ,name "."))
642     ((string= ,name ".."))
643     (t
644     ,@body))))
645     (unix:close-dir dir))))))
646     (if tail
647     (let ((piece (car tail)))
648     (etypecase piece
649     (simple-string
650     (let ((head (concatenate 'string head piece)))
651     (with-directory-node-noted (head)
652     (%enumerate-directories (concatenate 'string head "/")
653     (cdr tail) pathname
654     verify-existance follow-links
655     nodes function))))
656     ((member :wild-inferiors)
657     (%enumerate-directories head (rest tail) pathname
658     verify-existance follow-links
659     nodes function)
660     (do-directory-entries (name head)
661     (let ((subdir (concatenate 'string head name)))
662     (multiple-value-bind (res dev ino mode)
663     (unix-xstat subdir)
664     (declare (type (or fixnum null) mode))
665     (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
666     (unless (dolist (dir nodes nil)
667     (when (and (eql (car dir) dev)
668     (eql (cdr dir) ino))
669     (return t)))
670     (let ((nodes (cons (cons dev ino) nodes))
671     (subdir (concatenate 'string subdir "/")))
672     (%enumerate-directories subdir tail pathname
673     verify-existance follow-links
674     nodes function))))))))
675     ((or pattern (member :wild))
676     (do-directory-entries (name head)
677     (when (or (eq piece :wild) (pattern-matches piece name))
678     (let ((subdir (concatenate 'string head name)))
679     (multiple-value-bind (res dev ino mode)
680     (unix-xstat subdir)
681     (declare (type (or fixnum null) mode))
682     (when (and res
683     (eql (logand mode unix:s-ifmt) unix:s-ifdir))
684     (let ((nodes (cons (cons dev ino) nodes))
685     (subdir (concatenate 'string subdir "/")))
686     (%enumerate-directories subdir (rest tail) pathname
687     verify-existance follow-links
688     nodes function))))))))
689     ((member :up)
690     (let ((head (concatenate 'string head "..")))
691     (with-directory-node-noted (head)
692     (%enumerate-directories (concatenate 'string head "/")
693     (rest tail) pathname
694     verify-existance follow-links
695     nodes function))))))
696     (%enumerate-files head pathname verify-existance function))))
697 ram 1.1
698 wlott 1.16 (defun %enumerate-files (directory pathname verify-existance function)
699 ram 1.37 (declare (simple-string directory))
700 ram 1.36 (let ((name (%pathname-name pathname))
701     (type (%pathname-type pathname))
702     (version (%pathname-version pathname)))
703 ram 1.33 (cond ((member name '(nil :unspecific))
704 wlott 1.16 (when (or (not verify-existance)
705 wlott 1.26 (unix:unix-file-kind directory))
706 wlott 1.16 (funcall function directory)))
707     ((or (pattern-p name)
708     (pattern-p type)
709 ram 1.33 (eq name :wild)
710 rtoy 1.84 (eq type :wild)
711     (eq version :wild))
712 wlott 1.26 (let ((dir (unix:open-dir directory)))
713 wlott 1.16 (when dir
714     (unwind-protect
715     (loop
716 wlott 1.26 (let ((file (unix:read-dir dir)))
717 wlott 1.16 (if file
718 wlott 1.21 (unless (or (string= file ".")
719     (string= file ".."))
720     (multiple-value-bind
721     (file-name file-type file-version)
722     (let ((*ignore-wildcards* t))
723     (extract-name-type-and-version
724     file 0 (length file)))
725 toy 1.76 ;; Match also happens if the file has
726     ;; no explicit version and we're asking
727     ;; for version :NEWEST, since that's
728     ;; what no version means.
729 wlott 1.21 (when (and (components-match file-name name)
730     (components-match file-type type)
731 toy 1.76 (or (components-match file-version
732     version)
733     (and (eq file-version nil)
734     (eq version :newest))))
735 wlott 1.21 (funcall function
736     (concatenate 'string
737     directory
738     file)))))
739 wlott 1.16 (return))))
740 wlott 1.26 (unix:close-dir dir)))))
741 wlott 1.16 (t
742     (let ((file (concatenate 'string directory name)))
743 wlott 1.19 (unless (or (null type) (eq type :unspecific))
744 wlott 1.16 (setf file (concatenate 'string file "." type)))
745 toy 1.68 (unless (member version '(nil :newest :wild :unspecific))
746 toy 1.66 (setf file (concatenate 'string file ".~"
747     (quick-integer-to-string version)
748     "~")))
749 wlott 1.16 (when (or (not verify-existance)
750 ram 1.40 (unix:unix-file-kind file t))
751 wlott 1.16 (funcall function file)))))))
752 ram 1.1
753     (defun quick-integer-to-string (n)
754 wlott 1.16 (declare (type integer n))
755 ram 1.38 (cond ((not (fixnump n))
756     (write-to-string n :base 10 :radix nil))
757     ((zerop n) "0")
758 ram 1.1 ((eql n 1) "1")
759     ((minusp n)
760     (concatenate 'simple-string "-"
761     (the simple-string (quick-integer-to-string (- n)))))
762     (t
763     (do* ((len (1+ (truncate (integer-length n) 3)))
764     (res (make-string len))
765     (i (1- len) (1- i))
766     (q n)
767     (r 0))
768     ((zerop q)
769     (incf i)
770     (replace res res :start2 i :end2 len)
771 wlott 1.3 (shrink-vector res (- len i)))
772 ram 1.1 (declare (simple-string res)
773 ram 1.38 (fixnum len i r q))
774 ram 1.1 (multiple-value-setq (q r) (truncate q 10))
775     (setf (schar res i) (schar "0123456789" r))))))
776    
777 wlott 1.16
778     ;;;; UNIX-NAMESTRING -- public
779 wlott 1.5 ;;;
780 wlott 1.39 (defun unix-namestring (pathname &optional (for-input t) executable-only)
781 wlott 1.16 "Convert PATHNAME into a string that can be used with UNIX system calls.
782 pw 1.56 Search-lists and wild-cards are expanded. If optional argument
783     FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned.
784     If optional argument EXECUTABLE-ONLY is true, NIL is returned
785     unless an executable version of PATHNAME exists."
786 ram 1.41 ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
787     ;; pathnames too.
788     (let ((path (let ((lpn (pathname pathname)))
789     (if (logical-pathname-p lpn)
790     (namestring (translate-logical-pathname lpn))
791     pathname))))
792 wlott 1.16 (enumerate-search-list
793 ram 1.41 (pathname path)
794 wlott 1.16 (collect ((names))
795 dtc 1.57 (enumerate-matches (name pathname nil :verify-existance for-input
796     :follow-links t)
797 wlott 1.39 (when (or (not executable-only)
798     (and (eq (unix:unix-file-kind name) :file)
799     (unix:unix-access name unix:x_ok)))
800     (names name)))
801 wlott 1.16 (let ((names (names)))
802     (when names
803     (when (cdr names)
804 dtc 1.54 (error 'simple-file-error
805     :format-control "~S is ambiguous:~{~% ~A~}"
806     :format-arguments (list pathname names)))
807 ram 1.41 (return (car names))))))))
808 wlott 1.4
809 ram 1.1
810 wlott 1.16 ;;;; TRUENAME and PROBE-FILE.
811 ram 1.1
812     ;;; Truename -- Public
813     ;;;
814 wlott 1.4 ;;; Another silly file function trivially different from another function.
815 ram 1.1 ;;;
816     (defun truename (pathname)
817     "Return the pathname for the actual file described by the pathname
818 pw 1.47 An error of type file-error is signalled if no such file exists,
819     or the pathname is wild."
820     (if (wild-pathname-p pathname)
821 pw 1.51 (error 'simple-file-error
822 pw 1.47 :format-control "Bad place for a wild pathname."
823     :pathname pathname)
824     (let ((result (probe-file pathname)))
825     (unless result
826 pw 1.51 (error 'simple-file-error
827 pw 1.47 :pathname pathname
828     :format-control "The file ~S does not exist."
829     :format-arguments (list (namestring pathname))))
830     result)))
831 ram 1.1
832     ;;; Probe-File -- Public
833     ;;;
834 toy 1.71 ;;; If PATHNAME exists, return its truename, otherwise NIL.
835 ram 1.1 ;;;
836     (defun probe-file (pathname)
837     "Return a pathname which is the truename of the file if it exists, NIL
838 toy 1.73 otherwise. An error of type file-error is signalled if pathname is wild."
839 pw 1.47 (if (wild-pathname-p pathname)
840 pw 1.51 (error 'simple-file-error
841 pw 1.47 :pathname pathname
842     :format-control "Bad place for a wild pathname.")
843 toy 1.78 (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
844 pw 1.47 (when (and namestring (unix:unix-file-kind namestring))
845     (let ((truename (unix:unix-resolve-links
846     (unix:unix-maybe-prepend-current-directory
847     namestring))))
848     (when truename
849     (let ((*ignore-wildcards* t))
850     (pathname (unix:unix-simplify-pathname truename)))))))))
851 ram 1.1
852    
853 wlott 1.4 ;;;; Other random operations.
854 ram 1.1
855     ;;; Rename-File -- Public
856     ;;;
857     (defun rename-file (file new-name)
858     "Rename File to have the specified New-Name. If file is a stream open to a
859 ram 1.35 file, then the associated file is renamed."
860 wlott 1.4 (let* ((original (truename file))
861 wlott 1.16 (original-namestring (unix-namestring original t))
862 wlott 1.4 (new-name (merge-pathnames new-name original))
863     (new-namestring (unix-namestring new-name nil)))
864 wlott 1.17 (unless new-namestring
865 pw 1.51 (error 'simple-file-error
866 pw 1.47 :pathname new-name
867     :format-control "~S can't be created."
868     :format-arguments (list new-name)))
869 wlott 1.4 (multiple-value-bind (res error)
870 wlott 1.26 (unix:unix-rename original-namestring
871 wlott 1.4 new-namestring)
872     (unless res
873 pw 1.51 (error 'simple-file-error
874 pw 1.47 :pathname new-name
875     :format-control "Failed to rename ~A to ~A: ~A"
876     :format-arguments (list original new-name
877     (unix:get-unix-error-msg error))))
878 wlott 1.4 (when (streamp file)
879     (file-name file new-namestring))
880 wlott 1.16 (values new-name original (truename new-name)))))
881 ram 1.1
882     ;;; Delete-File -- Public
883     ;;;
884     ;;; Delete the file, Man.
885     ;;;
886     (defun delete-file (file)
887     "Delete the specified file."
888 wlott 1.4 (let ((namestring (unix-namestring file t)))
889 ram 1.1 (when (streamp file)
890 rtoy 1.79 ;; Close the file, but don't try to revert or anything. We want
891     ;; to delete it, man!
892     (close file))
893 ram 1.24 (unless namestring
894 pw 1.51 (error 'simple-file-error
895 pw 1.47 :pathname file
896     :format-control "~S doesn't exist."
897     :format-arguments (list file)))
898 ram 1.24
899 wlott 1.26 (multiple-value-bind (res err) (unix:unix-unlink namestring)
900 ram 1.24 (unless res
901 pw 1.51 (error 'simple-file-error
902 pw 1.47 :pathname namestring
903     :format-control "Could not delete ~A: ~A."
904     :format-arguments (list namestring
905     (unix:get-unix-error-msg err))))))
906 ram 1.1 t)
907 wlott 1.4
908 toy 1.75 ;;; Purge-Backup-Files -- Public
909 toy 1.73 ;;;
910     ;;; Purge old file versions
911     ;;;
912 toy 1.75 (defun purge-backup-files (pathname &optional (keep 0))
913 toy 1.73 "Delete old versions of files matching the given Pathname,
914     optionally keeping some of the most recent old versions."
915     (declare (type (or pathname string stream) pathname)
916     (type (integer 0 *) keep))
917     (let ((hash (make-hash-table :test 'equal)))
918     (enumerate-search-list
919     (path (make-pathname :version :wild :defaults pathname))
920     (clrhash hash)
921     (enumerate-matches (name path nil :follow-links nil)
922     (let ((dot (position #\. name :from-end t))
923     (len (length name)))
924     (when (and dot
925     (> len (+ dot 3))
926     (char= (char name (1+ dot)) #\~)
927     (char= (char name (1- len)) #\~)
928     (eq (unix:unix-file-kind name) :file))
929     (multiple-value-bind (version next)
930     (parse-integer name :start (+ dot 2) :end (1- len)
931     :junk-allowed t)
932     (when (and version (= next (1- len)))
933     (push (cons version name)
934     (gethash (subseq name 0 dot) hash '())))))))
935     (maphash (lambda (key value)
936     (declare (ignore key))
937     (mapc #'unix:unix-unlink
938     (mapcar #'cdr (nthcdr keep
939     (sort value #'> :key #'car)))))
940     hash))))
941    
942 ram 1.1
943     ;;; User-Homedir-Pathname -- Public
944     ;;;
945 ram 1.12 ;;; Return Home:, which is set up for us at initialization time.
946 ram 1.1 ;;;
947     (defun user-homedir-pathname (&optional host)
948     "Returns the home directory of the logged in user as a pathname.
949 ram 1.12 This is obtained from the logical name \"home:\"."
950 ram 1.1 (declare (ignore host))
951 ram 1.12 #p"home:")
952 ram 1.1
953     ;;; File-Write-Date -- Public
954     ;;;
955     (defun file-write-date (file)
956 pw 1.47 "Return file's creation date, or NIL if it doesn't exist.
957 toy 1.73 An error of type file-error is signalled if file is a wild pathname"
958 pw 1.47 (if (wild-pathname-p file)
959 pw 1.51 (error 'simple-file-error
960 pw 1.47 :pathname file
961     :format-control "Bad place for a wild pathname.")
962     (let ((name (unix-namestring file t)))
963     (when name
964     (multiple-value-bind
965     (res dev ino mode nlink uid gid rdev size atime mtime)
966     (unix:unix-stat name)
967     (declare (ignore dev ino mode nlink uid gid rdev size atime))
968     (when res
969     (+ unix-to-universal-time mtime)))))))
970 ram 1.1
971     ;;; File-Author -- Public
972     ;;;
973     (defun file-author (file)
974     "Returns the file author as a string, or nil if the author cannot be
975 pw 1.47 determined. Signals an error of type file-error if file doesn't exist,
976     or file is a wild pathname."
977     (if (wild-pathname-p file)
978 pw 1.51 (error 'simple-file-error
979 pw 1.47 :pathname file
980 emarsden 1.80 :format-control "Bad place for a wild pathname.")
981 pw 1.47 (let ((name (unix-namestring (pathname file) t)))
982     (unless name
983 pw 1.51 (error 'simple-file-error
984 pw 1.47 :pathname file
985     :format-control "~S doesn't exist."
986     :format-arguments (list file)))
987     (multiple-value-bind (winp dev ino mode nlink uid)
988     (unix:unix-stat name)
989     (declare (ignore dev ino mode nlink))
990 toy 1.71 (when winp
991     (let ((user-info (unix:unix-getpwuid uid)))
992     (when user-info
993     (unix:user-info-name user-info))))))))
994 ram 1.1
995    
996     ;;;; DIRECTORY.
997    
998 wlott 1.4 ;;; DIRECTORY -- public.
999 toy 1.71 ;;;
1000 ram 1.23 (defun directory (pathname &key (all t) (check-for-subdirs t)
1001 dtc 1.58 (truenamep t) (follow-links t))
1002 ram 1.1 "Returns a list of pathnames, one for each file that matches the given
1003 ram 1.23 pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This
1004 dtc 1.58 never includes Unix dot and dot-dot in the result. If :TRUENAMEP is NIL,
1005 toy 1.73 then symbolic links in the result are not expanded, which is not the
1006     default because TRUENAME does follow links and the result pathnames are
1007 ram 1.23 defined to be the TRUENAME of the pathname (the truename of a link may well
1008 toy 1.73 be in another directory). If FOLLOW-LINKS is NIL then symbolic links are
1009 dtc 1.58 not followed."
1010 wlott 1.16 (let ((results nil))
1011     (enumerate-search-list
1012 wlott 1.21 (pathname (merge-pathnames pathname
1013     (make-pathname :name :wild
1014     :type :wild
1015 toy 1.77 :version :wild
1016     :defaults *default-pathname-defaults*)
1017 toy 1.75 :wild))
1018 dtc 1.57 (enumerate-matches (name pathname nil :follow-links follow-links)
1019 wlott 1.16 (when (or all
1020     (let ((slash (position #\/ name :from-end t)))
1021     (or (null slash)
1022     (= (1+ slash) (length name))
1023     (char/= (schar name (1+ slash)) #\.))))
1024     (push name results))))
1025     (let ((*ignore-wildcards* t))
1026     (mapcar #'(lambda (name)
1027 ram 1.23 (let ((name (if (and check-for-subdirs
1028 wlott 1.26 (eq (unix:unix-file-kind name)
1029 ram 1.23 :directory))
1030     (concatenate 'string name "/")
1031     name)))
1032 dtc 1.58 (if truenamep (truename name) (pathname name))))
1033 wlott 1.16 (sort (delete-duplicates results :test #'string=) #'string<)))))
1034 ram 1.1
1035 wlott 1.4
1036     ;;;; Printing directories.
1037 ram 1.1
1038     ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
1039     ;;;
1040     (defun print-directory (pathname &optional stream &key all verbose return-list)
1041 toy 1.73 "Like Directory, but prints a terse, multi-column directory listing
1042 ram 1.1 instead of returning a list of pathnames. When :all is supplied and
1043 toy 1.73 non-nil, then Unix dot files are included too (as ls -a). When :verbose
1044 ram 1.1 is supplied and non-nil, then a long listing of miscellaneous
1045     information is output one file per line."
1046 dtc 1.50 (let ((*standard-output* (out-synonym-of stream))
1047 wlott 1.16 (pathname pathname))
1048 ram 1.1 (if verbose
1049     (print-directory-verbose pathname all return-list)
1050     (print-directory-formatted pathname all return-list))))
1051    
1052     (defun print-directory-verbose (pathname all return-list)
1053 ram 1.23 (let ((contents (directory pathname :all all :check-for-subdirs nil
1054 dtc 1.58 :truenamep nil))
1055 wlott 1.7 (result nil))
1056 toy 1.73 (format t "Directory of ~A:~%" (namestring pathname))
1057 wlott 1.7 (dolist (file contents)
1058     (let* ((namestring (unix-namestring file))
1059     (tail (subseq namestring
1060     (1+ (or (position #\/ namestring
1061     :from-end t
1062     :test #'char=)
1063     -1)))))
1064     (multiple-value-bind
1065     (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
1066 wlott 1.26 (unix:unix-stat namestring)
1067 wlott 1.7 (declare (ignore ino gid rdev atime)
1068     (fixnum uid mode))
1069     (cond (reslt
1070     ;;
1071     ;; Print characters for file modes.
1072     (macrolet ((frob (bit name &optional sbit sname negate)
1073     `(if ,(if negate
1074     `(not (logbitp ,bit mode))
1075     `(logbitp ,bit mode))
1076     ,(if sbit
1077     `(if (logbitp ,sbit mode)
1078     (write-char ,sname)
1079     (write-char ,name))
1080     `(write-char ,name))
1081     (write-char #\-))))
1082     (frob 15 #\d nil nil t)
1083     (frob 8 #\r)
1084     (frob 7 #\w)
1085     (frob 6 #\x 11 #\s)
1086     (frob 5 #\r)
1087     (frob 4 #\w)
1088     (frob 3 #\x 10 #\s)
1089     (frob 2 #\r)
1090     (frob 1 #\w)
1091     (frob 0 #\x))
1092     ;;
1093     ;; Print the rest.
1094     (multiple-value-bind (sec min hour date month year)
1095     (get-decoded-time)
1096     (declare (ignore sec min hour date month))
1097     (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"
1098     nlink
1099 toy 1.71 (let ((user-info (unix:unix-getpwuid uid)))
1100     (if user-info (unix:user-info-name user-info) uid))
1101 wlott 1.7 size
1102     (decode-universal-time-for-files mtime year)
1103     tail
1104 wlott 1.27 (= (logand mode unix:s-ifmt) unix:s-ifdir))))
1105 wlott 1.7 (t (format t "Couldn't stat ~A -- ~A.~%"
1106     tail
1107 wlott 1.26 (unix:get-unix-error-msg dev-or-err))))
1108 ram 1.1 (when return-list
1109 wlott 1.27 (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
1110 wlott 1.7 (pathname (concatenate 'string namestring "/"))
1111     file)
1112     result)))))
1113     (nreverse result)))
1114 ram 1.1
1115     (defun decode-universal-time-for-files (time current-year)
1116     (multiple-value-bind (sec min hour day month year)
1117     (decode-universal-time (+ time unix-to-universal-time))
1118     (declare (ignore sec))
1119     (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
1120     (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
1121     "Sep" "Oct" "Nov" "Dec")
1122     (1- month))
1123     day (= current-year year) year hour min)))
1124    
1125     (defun print-directory-formatted (pathname all return-list)
1126     (let ((width (or (line-length *standard-output*) 80))
1127     (names ())
1128     (cnt 0)
1129     (max-len 0)
1130 dtc 1.58 (result (directory pathname :all all :truenamep nil)))
1131 ram 1.1 (declare (list names) (fixnum max-len cnt))
1132     ;;
1133     ;; Get the data.
1134 wlott 1.7 (dolist (file result)
1135     (let* ((name (unix-namestring file))
1136     (length (length name))
1137     (end (if (and (plusp length)
1138     (char= (schar name (1- length)) #\/))
1139     (1- length)
1140     length))
1141     (slash-name (subseq name
1142     (1+ (or (position #\/ name
1143     :from-end t
1144     :end end
1145     :test #'char=)
1146     -1))))
1147     (len (length slash-name)))
1148     (declare (simple-string slash-name)
1149     (fixnum len))
1150     (if (> len max-len) (setq max-len len))
1151     (incf cnt)
1152     (push slash-name names)))
1153     (setq names (nreverse names))
1154     ;;
1155     ;; Do the output.
1156     (let* ((col-width (1+ max-len))
1157     (cols (max (truncate width col-width) 1))
1158     (lines (ceiling cnt cols)))
1159     (declare (fixnum cols lines))
1160 toy 1.73 (format t "Directory of ~A:~%" (namestring pathname))
1161 wlott 1.7 (dotimes (i lines)
1162     (declare (fixnum i))
1163     (dotimes (j cols)
1164     (declare (fixnum j))
1165     (let ((name (nth (+ i (the fixnum (* j lines))) names)))
1166     (when name
1167     (write-string name)
1168     (unless (eql j (1- cols))
1169 wlott 1.15 (dotimes (i (- col-width (length (the simple-string name))))
1170     (write-char #\space))))))
1171 wlott 1.7 (terpri)))
1172     (when return-list
1173     result)))
1174 ram 1.1
1175    
1176 wlott 1.4 ;;;; File completion.
1177 ram 1.1
1178 chiles 1.13 ;;; COMPLETE-FILE -- Public
1179     ;;;
1180 wlott 1.4 (defun complete-file (pathname &key (defaults *default-pathname-defaults*)
1181     ignore-types)
1182 wlott 1.22 (let ((files (directory (complete-file-directory-arg pathname defaults)
1183 ram 1.23 :check-for-subdirs nil
1184 dtc 1.58 :truenamep nil)))
1185 wlott 1.4 (cond ((null files)
1186     (values nil nil))
1187     ((null (cdr files))
1188     (values (merge-pathnames (file-namestring (car files))
1189     pathname)
1190     t))
1191     (t
1192     (let ((good-files
1193     (delete-if #'(lambda (pathname)
1194 wlott 1.16 (and (simple-string-p
1195     (pathname-type pathname))
1196 wlott 1.4 (member (pathname-type pathname)
1197     ignore-types
1198     :test #'string=)))
1199     files)))
1200     (cond ((null good-files))
1201     ((null (cdr good-files))
1202     (return-from complete-file
1203     (values (merge-pathnames (file-namestring
1204     (car good-files))
1205     pathname)
1206     t)))
1207     (t
1208     (setf files good-files)))
1209     (let ((common (file-namestring (car files))))
1210     (dolist (file (cdr files))
1211     (let ((name (file-namestring file)))
1212     (dotimes (i (min (length common) (length name))
1213     (when (< (length name) (length common))
1214     (setf common name)))
1215     (unless (char= (schar common i) (schar name i))
1216     (setf common (subseq common 0 i))
1217     (return)))))
1218     (values (merge-pathnames common pathname)
1219     nil)))))))
1220 ram 1.1
1221 chiles 1.13 ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
1222     ;;;
1223     (defun complete-file-directory-arg (pathname defaults)
1224 wlott 1.22 (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
1225 wlott 1.16 (type (pathname-type pathname)))
1226     (flet ((append-multi-char-wild (thing)
1227     (etypecase thing
1228     (null :wild)
1229     (pattern
1230     (make-pattern (append (pattern-pieces thing)
1231     (list :multi-char-wild))))
1232     (simple-string
1233     (make-pattern (list thing :multi-char-wild))))))
1234     (if (or (null type) (eq type :unspecific))
1235     ;; There is no type.
1236     (make-pathname :defaults pathname
1237     :name (append-multi-char-wild (pathname-name pathname))
1238     :type :wild)
1239     ;; There already is a type, so just extend it.
1240     (make-pathname :defaults pathname
1241     :name (pathname-name pathname)
1242     :type (append-multi-char-wild (pathname-type pathname)))))))
1243 chiles 1.13
1244 wlott 1.4 ;;; Ambiguous-Files -- Public
1245 ram 1.1 ;;;
1246 wlott 1.16 (defun ambiguous-files (pathname
1247     &optional (defaults *default-pathname-defaults*))
1248 wlott 1.4 "Return a list of all files which are possible completions of Pathname.
1249 chiles 1.13 We look in the directory specified by Defaults as well as looking down
1250     the search list."
1251 wlott 1.16 (directory (complete-file-directory-arg pathname defaults)
1252 dtc 1.58 :truenamep nil
1253 wlott 1.16 :check-for-subdirs nil))
1254 wlott 1.4
1255 wlott 1.16
1256 ram 1.1
1257     ;;; File-writable -- exported from extensions.
1258     ;;;
1259     ;;; Determines whether the single argument (which should be a pathname)
1260 dtc 1.46 ;;; can be written by the current task.
1261 wlott 1.16 ;;;
1262 ram 1.1 (defun file-writable (name)
1263     "File-writable accepts a pathname and returns T if the current
1264     process can write it, and NIL otherwise."
1265 wlott 1.16 (let ((name (unix-namestring name nil)))
1266 wlott 1.17 (cond ((null name)
1267     nil)
1268 wlott 1.26 ((unix:unix-file-kind name)
1269     (values (unix:unix-access name unix:w_ok)))
1270 wlott 1.17 (t
1271     (values
1272 wlott 1.26 (unix:unix-access (subseq name
1273 wlott 1.17 0
1274     (or (position #\/ name :from-end t)
1275     0))
1276 wlott 1.26 (logior unix:w_ok unix:x_ok)))))))
1277 ram 1.1
1278    
1279     ;;; Pathname-Order -- Internal
1280     ;;;
1281     ;;; Predicate to order pathnames by. Goes by name.
1282     ;;;
1283     (defun pathname-order (x y)
1284     (let ((xn (%pathname-name x))
1285     (yn (%pathname-name y)))
1286     (if (and xn yn)
1287     (let ((res (string-lessp xn yn)))
1288     (cond ((not res) nil)
1289     ((= res (length (the simple-string xn))) t)
1290     ((= res (length (the simple-string yn))) nil)
1291     (t t)))
1292     xn)))
1293    
1294    
1295     ;;; Default-Directory -- Public
1296     ;;;
1297     (defun default-directory ()
1298     "Returns the pathname for the default directory. This is the place where
1299     a file will be written if no directory is specified. This may be changed
1300     with setf."
1301     (multiple-value-bind (gr dir-or-error)
1302 wlott 1.26 (unix:unix-current-directory)
1303 ram 1.1 (if gr
1304 wlott 1.16 (let ((*ignore-wildcards* t))
1305 toy 1.70 (values
1306     (parse-namestring (concatenate 'simple-string dir-or-error "/")
1307     *unix-host*)))
1308 wlott 1.3 (error dir-or-error))))
1309 ram 1.1
1310     ;;; %Set-Default-Directory -- Internal
1311     ;;;
1312     (defun %set-default-directory (new-val)
1313 wlott 1.17 (let ((namestring (unix-namestring new-val t)))
1314     (unless namestring
1315 toy 1.67 (error 'simple-file-error
1316     :format-control "~S doesn't exist."
1317     :format-arguments (list new-val)))
1318 wlott 1.17 (multiple-value-bind (gr error)
1319 wlott 1.26 (unix:unix-chdir namestring)
1320 wlott 1.17 (if gr
1321     (setf (search-list "default:") (default-directory))
1322 wlott 1.26 (error (unix:get-unix-error-msg error))))
1323 wlott 1.17 new-val))
1324 wlott 1.16 ;;;
1325     (defsetf default-directory %set-default-directory)
1326    
1327     (defun filesys-init ()
1328 toy 1.74 ;; Use :unspecific so we don't create file versions whenever merging
1329     ;; happens. If the user wants that, let him change
1330     ;; *default-pathname-defaults* appropriately.
1331 wlott 1.16 (setf *default-pathname-defaults*
1332 toy 1.74 (%make-pathname *unix-host* nil nil nil nil :unspecific))
1333 wlott 1.16 (setf (search-list "default:") (default-directory))
1334     nil)
1335 dtc 1.42
1336     ;;; Ensure-Directories-Exist -- Public
1337     ;;;
1338     (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1339 pw 1.44 "Tests whether the directories containing the specified file
1340     actually exist, and attempts to create them if they do not.
1341     Portable programs should avoid using the :MODE keyword argument."
1342 dtc 1.43 (let* ((pathname (pathname pathspec))
1343     (pathname (if (logical-pathname-p pathname)
1344     (translate-logical-pathname pathname)
1345     pathname))
1346     (created-p nil))
1347     (when (wild-pathname-p pathname)
1348 pw 1.51 (error 'simple-file-error
1349 pw 1.47 :format-control "Bad place for a wild pathname."
1350     :pathname pathspec))
1351 dtc 1.45 (enumerate-search-list (pathname pathname)
1352     (let ((dir (pathname-directory pathname)))
1353     (loop for i from 1 upto (length dir)
1354     do (let ((newpath (make-pathname
1355     :host (pathname-host pathname)
1356     :device (pathname-device pathname)
1357     :directory (subseq dir 0 i))))
1358 rtoy 1.87 (tagbody
1359     retry
1360     (restart-case
1361     (unless (probe-file newpath)
1362     (let ((namestring (namestring newpath)))
1363     (when verbose
1364     (format *standard-output* "~&Creating directory: ~A~%"
1365     namestring))
1366     (unix:unix-mkdir namestring mode)
1367     (unless (probe-file namestring)
1368     (error 'simple-file-error
1369     :pathname pathspec
1370     :format-control "Can't create directory ~A."
1371     :format-arguments (list namestring)))
1372     (setf created-p t)))
1373     (retry () :report "Try to create the directory again"
1374     (go retry))))))
1375 dtc 1.45 ;; Only the first path in a search-list is considered.
1376     (return (values pathname created-p))))))

  ViewVC Help
Powered by ViewVC 1.1.5