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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.60 - (hide annotations)
Fri Feb 23 18:56:11 2001 UTC (13 years, 1 month ago) by dtc
Branch: MAIN
Changes since 1.59: +8 -8 lines
o Fix some problems in the parsing within extract-name-type-and-version.
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;; **********************************************************************
3 ram 1.8 ;;; 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 dtc 1.60 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/filesys.lisp,v 1.60 2001/02/23 18:56:11 dtc Exp $")
10 ram 1.8 ;;;
11 ram 1.1 ;;; **********************************************************************
12     ;;;
13 wlott 1.16 ;;; File system interface functions. This file is pretty UNIX specific.
14 ram 1.1 ;;;
15 wlott 1.16 ;;; Written by William Lott
16 ram 1.1 ;;;
17     ;;; **********************************************************************
18 ram 1.2
19     (in-package "LISP")
20    
21 wlott 1.16 (export '(truename probe-file user-homedir-pathname directory
22     rename-file delete-file file-write-date file-author))
23 ram 1.1
24     (use-package "EXTENSIONS")
25    
26     (in-package "EXTENSIONS")
27     (export '(print-directory complete-file ambiguous-files default-directory
28 wlott 1.5 file-writable unix-namestring))
29 ram 1.2 (in-package "LISP")
30 ram 1.1
31 wlott 1.5
32 wlott 1.16 ;;;; Unix pathname host support.
33 ram 1.1
34 wlott 1.16 ;;; 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 dtc 1.59 ;;; version := ".~" ([0-9]+ | "*") "~"
42 wlott 1.16 ;;;
43 dtc 1.59 ;;; Note: this grammer is ambiguous. The string foo.bar.~5~ can be parsed
44 wlott 1.16 ;;; 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 ram 1.1
72 wlott 1.16 (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 ram 1.1
100 wlott 1.16 (defvar *ignore-wildcards* nil)
101 ram 1.1
102 wlott 1.16 (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 ram 1.31 ((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 wlott 1.16 (t
171     (make-pattern (pattern)))))))
172 ram 1.1
173 dtc 1.59 ;;; extract-name-type-and-version -- Internal.
174     ;;;
175 wlott 1.16 (defun extract-name-type-and-version (namestr start end)
176     (declare (type simple-base-string namestr)
177     (type index start end))
178 dtc 1.59 (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 dtc 1.60 ((< i (+ start 2)) (values :newest end))
189 dtc 1.59 (let ((char (schar namestr i)))
190     (when (eql char #\~)
191 dtc 1.60 (return (if (char= (schar namestr (1- i)) #\.)
192     (values (parse-integer namestr :start (1+ i)
193     :end (1- end))
194     (1- i))
195     (values :newest end))))
196 dtc 1.59 (unless (char<= #\0 char #\9)
197 dtc 1.60 (return (values :newest end)))))))
198 dtc 1.59 (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 wlott 1.16 (t
205 dtc 1.59 (values (maybe-make-pattern namestr start vstart)
206     nil
207     version))))))
208 ram 1.1
209 ram 1.31 ;;; 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 wlott 1.16 (type index start end))
215     (let ((absolute (and (/= start end)
216 ram 1.31 (char= (schar namestr start) #\/))))
217 wlott 1.16 (when absolute
218     (incf start))
219 ram 1.31 ;; Next, split the remainder into slash seperated chunks.
220 wlott 1.16 (collect ((pieces))
221     (loop
222 ram 1.31 (let ((slash (position #\/ namestr :start start :end end)))
223     (pieces (cons start (or slash end)))
224     (unless slash
225 wlott 1.16 (return))
226 ram 1.31 (setf start (1+ slash))))
227 wlott 1.16 (values absolute (pieces)))))
228 ram 1.1
229 wlott 1.16 (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 ram 1.1
245 wlott 1.16 (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 dtc 1.54 ;; 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 wlott 1.16 ;; 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 ram 1.31 (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 wlott 1.25 (cond (absolute
299     (cons :absolute (dirs)))
300     ((dirs)
301     (cons :relative (dirs)))
302     (t
303     nil)))
304 wlott 1.16 name
305     type
306     version)))))
307 ram 1.1
308 wlott 1.16 (defun unparse-unix-host (pathname)
309     (declare (type pathname pathname)
310     (ignore pathname))
311     "Unix")
312 ram 1.1
313 wlott 1.16 (defun unparse-unix-piece (thing)
314     (etypecase thing
315 ram 1.31 ((member :wild) "*")
316 wlott 1.16 (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 ram 1.31 (ecase piece
342 wlott 1.16 (:multi-char-wild
343     (strings "*"))
344     (:single-char-wild
345 ram 1.31 (strings "?"))))
346 wlott 1.16 (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 ram 1.1
358 wlott 1.16 (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 ram 1.31 ((member :wild-inferiors)
379     (pieces "**/"))
380 wlott 1.16 ((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 ram 1.1
387 wlott 1.16 (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 dtc 1.59 ".~~*~~"
409     (format nil ".~~~D~~" version)))))
410 pw 1.55 (and (strings) (apply #'concatenate 'simple-string (strings)))))
411 ram 1.1
412 wlott 1.16 (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 ram 1.1
418 wlott 1.16 (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 dtc 1.59 (strings ".~~*~~"))
468 wlott 1.16 (integer
469 dtc 1.59 (strings (format nil ".~~~D~~" pathname-version)))
470 wlott 1.16 (t
471     (lose)))))
472     (apply #'concatenate 'simple-string (strings)))))
473 ram 1.1
474    
475 wlott 1.16 (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 ram 1.1
487 wlott 1.16 (defvar *unix-host* (make-unix-host))
488 ram 1.1
489 wlott 1.16 (defun make-unix-host-load-form (host)
490     (declare (ignore host))
491     '*unix-host*)
492 ram 1.1
493 wlott 1.16
494     ;;;; Wildcard matching stuff.
495 ram 1.1
496 wlott 1.16 (defmacro enumerate-matches ((var pathname &optional result
497 dtc 1.57 &key (verify-existance t) (follow-links t))
498 wlott 1.16 &body body)
499     (let ((body-name (gensym)))
500     `(block nil
501     (flet ((,body-name (,var)
502     ,@body))
503     (%enumerate-matches (pathname ,pathname)
504 dtc 1.57 ,verify-existance ,follow-links
505 wlott 1.16 #',body-name)
506     ,result))))
507 ram 1.1
508 dtc 1.57 (defun %enumerate-matches (pathname verify-existance follow-links function)
509 ram 1.34 (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 dtc 1.57 verify-existance follow-links
518     nil function))
519 ram 1.34 (:relative
520     (%enumerate-directories "" (cdr directory) pathname
521 dtc 1.57 verify-existance follow-links
522     nil function)))
523 ram 1.34 (%enumerate-files "" pathname verify-existance function))))
524 ram 1.1
525 dtc 1.57 ;;; %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 ram 1.37 (declare (simple-string head))
533 dtc 1.57 (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 ram 1.1
608 wlott 1.16 (defun %enumerate-files (directory pathname verify-existance function)
609 ram 1.37 (declare (simple-string directory))
610 ram 1.36 (let ((name (%pathname-name pathname))
611     (type (%pathname-type pathname))
612     (version (%pathname-version pathname)))
613 ram 1.33 (cond ((member name '(nil :unspecific))
614 wlott 1.16 (when (or (not verify-existance)
615 wlott 1.26 (unix:unix-file-kind directory))
616 wlott 1.16 (funcall function directory)))
617     ((or (pattern-p name)
618     (pattern-p type)
619 ram 1.33 (eq name :wild)
620     (eq type :wild))
621 wlott 1.26 (let ((dir (unix:open-dir directory)))
622 wlott 1.16 (when dir
623     (unwind-protect
624     (loop
625 wlott 1.26 (let ((file (unix:read-dir dir)))
626 wlott 1.16 (if file
627 wlott 1.21 (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 wlott 1.16 (return))))
643 wlott 1.26 (unix:close-dir dir)))))
644 wlott 1.16 (t
645     (let ((file (concatenate 'string directory name)))
646 wlott 1.19 (unless (or (null type) (eq type :unspecific))
647 wlott 1.16 (setf file (concatenate 'string file "." type)))
648 ram 1.33 (unless (member version '(nil :newest :wild))
649 wlott 1.19 (setf file (concatenate 'string file "."
650 wlott 1.20 (quick-integer-to-string version))))
651 wlott 1.16 (when (or (not verify-existance)
652 ram 1.40 (unix:unix-file-kind file t))
653 wlott 1.16 (funcall function file)))))))
654 ram 1.1
655     (defun quick-integer-to-string (n)
656 wlott 1.16 (declare (type integer n))
657 ram 1.38 (cond ((not (fixnump n))
658     (write-to-string n :base 10 :radix nil))
659     ((zerop n) "0")
660 ram 1.1 ((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 wlott 1.3 (shrink-vector res (- len i)))
674 ram 1.1 (declare (simple-string res)
675 ram 1.38 (fixnum len i r q))
676 ram 1.1 (multiple-value-setq (q r) (truncate q 10))
677     (setf (schar res i) (schar "0123456789" r))))))
678    
679 wlott 1.16
680     ;;;; UNIX-NAMESTRING -- public
681 wlott 1.5 ;;;
682 wlott 1.39 (defun unix-namestring (pathname &optional (for-input t) executable-only)
683 wlott 1.16 "Convert PATHNAME into a string that can be used with UNIX system calls.
684 pw 1.56 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 ram 1.41 ;; 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 wlott 1.16 (enumerate-search-list
695 ram 1.41 (pathname path)
696 wlott 1.16 (collect ((names))
697 dtc 1.57 (enumerate-matches (name pathname nil :verify-existance for-input
698     :follow-links t)
699 wlott 1.39 (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 wlott 1.16 (let ((names (names)))
704     (when names
705     (when (cdr names)
706 dtc 1.54 (error 'simple-file-error
707     :format-control "~S is ambiguous:~{~% ~A~}"
708     :format-arguments (list pathname names)))
709 ram 1.41 (return (car names))))))))
710 wlott 1.4
711 ram 1.1
712 wlott 1.16 ;;;; TRUENAME and PROBE-FILE.
713 ram 1.1
714     ;;; Truename -- Public
715     ;;;
716 wlott 1.4 ;;; Another silly file function trivially different from another function.
717 ram 1.1 ;;;
718     (defun truename (pathname)
719     "Return the pathname for the actual file described by the pathname
720 pw 1.47 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 pw 1.51 (error 'simple-file-error
724 pw 1.47 :format-control "Bad place for a wild pathname."
725     :pathname pathname)
726     (let ((result (probe-file pathname)))
727     (unless result
728 pw 1.51 (error 'simple-file-error
729 pw 1.47 :pathname pathname
730     :format-control "The file ~S does not exist."
731     :format-arguments (list (namestring pathname))))
732     result)))
733 ram 1.1
734     ;;; Probe-File -- Public
735     ;;;
736 wlott 1.4 ;;; If PATHNAME exists, return it's truename, otherwise NIL.
737 ram 1.1 ;;;
738     (defun probe-file (pathname)
739     "Return a pathname which is the truename of the file if it exists, NIL
740 pw 1.47 otherwise. An error of type file-error is signaled if pathname is wild."
741     (if (wild-pathname-p pathname)
742 pw 1.51 (error 'simple-file-error
743 pw 1.47 :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 ram 1.1
754    
755 wlott 1.4 ;;;; Other random operations.
756 ram 1.1
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 ram 1.35 file, then the associated file is renamed."
762 wlott 1.4 (let* ((original (truename file))
763 wlott 1.16 (original-namestring (unix-namestring original t))
764 wlott 1.4 (new-name (merge-pathnames new-name original))
765     (new-namestring (unix-namestring new-name nil)))
766 wlott 1.17 (unless new-namestring
767 pw 1.51 (error 'simple-file-error
768 pw 1.47 :pathname new-name
769     :format-control "~S can't be created."
770     :format-arguments (list new-name)))
771 wlott 1.4 (multiple-value-bind (res error)
772 wlott 1.26 (unix:unix-rename original-namestring
773 wlott 1.4 new-namestring)
774     (unless res
775 pw 1.51 (error 'simple-file-error
776 pw 1.47 :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 wlott 1.4 (when (streamp file)
781     (file-name file new-namestring))
782 wlott 1.16 (values new-name original (truename new-name)))))
783 ram 1.1
784     ;;; Delete-File -- Public
785     ;;;
786     ;;; Delete the file, Man.
787     ;;;
788     (defun delete-file (file)
789     "Delete the specified file."
790 wlott 1.4 (let ((namestring (unix-namestring file t)))
791 ram 1.1 (when (streamp file)
792     (close file :abort t))
793 ram 1.24 (unless namestring
794 pw 1.51 (error 'simple-file-error
795 pw 1.47 :pathname file
796     :format-control "~S doesn't exist."
797     :format-arguments (list file)))
798 ram 1.24
799 wlott 1.26 (multiple-value-bind (res err) (unix:unix-unlink namestring)
800 ram 1.24 (unless res
801 pw 1.51 (error 'simple-file-error
802 pw 1.47 :pathname namestring
803     :format-control "Could not delete ~A: ~A."
804     :format-arguments (list namestring
805     (unix:get-unix-error-msg err))))))
806 ram 1.1 t)
807 wlott 1.4
808 ram 1.1
809     ;;; User-Homedir-Pathname -- Public
810     ;;;
811 ram 1.12 ;;; Return Home:, which is set up for us at initialization time.
812 ram 1.1 ;;;
813     (defun user-homedir-pathname (&optional host)
814     "Returns the home directory of the logged in user as a pathname.
815 ram 1.12 This is obtained from the logical name \"home:\"."
816 ram 1.1 (declare (ignore host))
817 ram 1.12 #p"home:")
818 ram 1.1
819     ;;; File-Write-Date -- Public
820     ;;;
821     (defun file-write-date (file)
822 pw 1.47 "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 pw 1.51 (error 'simple-file-error
826 pw 1.47 :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 ram 1.1
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 pw 1.47 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 pw 1.51 (error 'simple-file-error
845 pw 1.47 :pathname file
846     "Bad place for a wild pathname.")
847     (let ((name (unix-namestring (pathname file) t)))
848     (unless name
849 pw 1.51 (error 'simple-file-error
850 pw 1.47 :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 ram 1.1
858    
859     ;;;; DIRECTORY.
860    
861 wlott 1.4 ;;; DIRECTORY -- public.
862     ;;;
863 ram 1.23 (defun directory (pathname &key (all t) (check-for-subdirs t)
864 dtc 1.58 (truenamep t) (follow-links t))
865 ram 1.1 "Returns a list of pathnames, one for each file that matches the given
866 ram 1.23 pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This
867 dtc 1.58 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 ram 1.23 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 dtc 1.58 be in another directory.) If FOLLOW-LINKS is NIL then symbolic links are
872     not followed."
873 wlott 1.16 (let ((results nil))
874     (enumerate-search-list
875 wlott 1.21 (pathname (merge-pathnames pathname
876     (make-pathname :name :wild
877     :type :wild
878     :version :wild)))
879 dtc 1.57 (enumerate-matches (name pathname nil :follow-links follow-links)
880 wlott 1.16 (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 ram 1.23 (let ((name (if (and check-for-subdirs
889 wlott 1.26 (eq (unix:unix-file-kind name)
890 ram 1.23 :directory))
891     (concatenate 'string name "/")
892     name)))
893 dtc 1.58 (if truenamep (truename name) (pathname name))))
894 wlott 1.16 (sort (delete-duplicates results :test #'string=) #'string<)))))
895 ram 1.1
896 wlott 1.4
897     ;;;; Printing directories.
898 ram 1.1
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 dtc 1.50 (let ((*standard-output* (out-synonym-of stream))
908 wlott 1.16 (pathname pathname))
909 ram 1.1 (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 ram 1.23 (let ((contents (directory pathname :all all :check-for-subdirs nil
915 dtc 1.58 :truenamep nil))
916 wlott 1.7 (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 wlott 1.26 (unix:unix-stat namestring)
928 wlott 1.7 (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 wlott 1.27 (= (logand mode unix:s-ifmt) unix:s-ifdir))))
965 wlott 1.7 (t (format t "Couldn't stat ~A -- ~A.~%"
966     tail
967 wlott 1.26 (unix:get-unix-error-msg dev-or-err))))
968 ram 1.1 (when return-list
969 wlott 1.27 (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
970 wlott 1.7 (pathname (concatenate 'string namestring "/"))
971     file)
972     result)))))
973     (nreverse result)))
974 ram 1.1
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 dtc 1.58 (result (directory pathname :all all :truenamep nil)))
991 ram 1.1 (declare (list names) (fixnum max-len cnt))
992     ;;
993     ;; Get the data.
994 wlott 1.7 (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 wlott 1.15 (dotimes (i (- col-width (length (the simple-string name))))
1030     (write-char #\space))))))
1031 wlott 1.7 (terpri)))
1032     (when return-list
1033     result)))
1034 ram 1.1
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 wlott 1.4 ;;;; File completion.
1112 ram 1.1
1113 chiles 1.13 ;;; COMPLETE-FILE -- Public
1114     ;;;
1115 wlott 1.4 (defun complete-file (pathname &key (defaults *default-pathname-defaults*)
1116     ignore-types)
1117 wlott 1.22 (let ((files (directory (complete-file-directory-arg pathname defaults)
1118 ram 1.23 :check-for-subdirs nil
1119 dtc 1.58 :truenamep nil)))
1120 wlott 1.4 (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 wlott 1.16 (and (simple-string-p
1130     (pathname-type pathname))
1131 wlott 1.4 (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 ram 1.1
1156 chiles 1.13 ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
1157     ;;;
1158     (defun complete-file-directory-arg (pathname defaults)
1159 wlott 1.22 (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
1160 wlott 1.16 (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 chiles 1.13
1179 wlott 1.4 ;;; Ambiguous-Files -- Public
1180 ram 1.1 ;;;
1181 wlott 1.16 (defun ambiguous-files (pathname
1182     &optional (defaults *default-pathname-defaults*))
1183 wlott 1.4 "Return a list of all files which are possible completions of Pathname.
1184 chiles 1.13 We look in the directory specified by Defaults as well as looking down
1185     the search list."
1186 wlott 1.16 (directory (complete-file-directory-arg pathname defaults)
1187 dtc 1.58 :truenamep nil
1188 wlott 1.16 :check-for-subdirs nil))
1189 wlott 1.4
1190 wlott 1.16
1191 ram 1.1
1192     ;;; File-writable -- exported from extensions.
1193     ;;;
1194     ;;; Determines whether the single argument (which should be a pathname)
1195 dtc 1.46 ;;; can be written by the current task.
1196 wlott 1.16 ;;;
1197 ram 1.1 (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 wlott 1.16 (let ((name (unix-namestring name nil)))
1201 wlott 1.17 (cond ((null name)
1202     nil)
1203 wlott 1.26 ((unix:unix-file-kind name)
1204     (values (unix:unix-access name unix:w_ok)))
1205 wlott 1.17 (t
1206     (values
1207 wlott 1.26 (unix:unix-access (subseq name
1208 wlott 1.17 0
1209     (or (position #\/ name :from-end t)
1210     0))
1211 wlott 1.26 (logior unix:w_ok unix:x_ok)))))))
1212 ram 1.1
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 wlott 1.26 (unix:unix-current-directory)
1238 ram 1.1 (if gr
1239 wlott 1.16 (let ((*ignore-wildcards* t))
1240     (pathname (concatenate 'simple-string dir-or-error "/")))
1241 wlott 1.3 (error dir-or-error))))
1242 ram 1.1
1243     ;;; %Set-Default-Directory -- Internal
1244     ;;;
1245     (defun %set-default-directory (new-val)
1246 wlott 1.17 (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 wlott 1.26 (unix:unix-chdir namestring)
1251 wlott 1.17 (if gr
1252     (setf (search-list "default:") (default-directory))
1253 wlott 1.26 (error (unix:get-unix-error-msg error))))
1254 wlott 1.17 new-val))
1255 wlott 1.16 ;;;
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 dtc 1.42
1264     ;;; Ensure-Directories-Exist -- Public
1265     ;;;
1266     (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1267 pw 1.44 "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 dtc 1.43 (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 pw 1.51 (error 'simple-file-error
1277 pw 1.47 :format-control "Bad place for a wild pathname."
1278     :pathname pathspec))
1279 dtc 1.45 (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 pw 1.51 (error 'simple-file-error
1294 pw 1.47 :pathname pathspec
1295     :format-control "Can't create directory ~A."
1296 pw 1.48 :format-arguments (list namestring)))
1297 dtc 1.45 (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