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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5