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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (hide annotations)
Tue Jun 10 16:52:36 2003 UTC (10 years, 10 months ago) by toy
Branch: MAIN
Changes since 1.72: +63 -27 lines
Some changes from Paul Foley:

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

  ViewVC Help
Powered by ViewVC 1.1.5