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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5