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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.69 - (show annotations)
Wed Oct 16 14:01:01 2002 UTC (11 years, 6 months ago) by toy
Branch: MAIN
Changes since 1.68: +5 -2 lines
Port over SBCL's fix for the Entomotomy bug

host-namestring-return-value-unusable
logical-pathnames-not-externalizable

host-namestring returns "" for physical pathnames when it used to
return "Unix".  But "Unix" is a valid logical host name and "" is not.

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

  ViewVC Help
Powered by ViewVC 1.1.5