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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5