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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5