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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5