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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (show annotations)
Tue Jun 10 16:52:36 2003 UTC (10 years, 10 months ago) by toy
Branch: MAIN
Changes since 1.72: +63 -27 lines
Some changes from Paul Foley:

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

  ViewVC Help
Powered by ViewVC 1.1.5