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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5