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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5