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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.92 - (hide annotations)
Sun Sep 25 21:47:48 2005 UTC (8 years, 6 months ago) by rtoy
Branch: MAIN
Changes since 1.91: +17 -5 lines
extract-name-type-and-version:
o Leave some debugging prints in, but commented out.
o In the last case for EXPLICIT-VERSION, when looking for digits
  surrounded by ~'s, return version NIL if we don't find just digits.
  #p"foo.*" was returning version :newest.  I think we really want
  :version nil.

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

  ViewVC Help
Powered by ViewVC 1.1.5