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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2.1.2 - (hide annotations) (vendor branch)
Sat May 26 22:58:18 1990 UTC (23 years, 10 months ago) by wlott
Changes since 1.2.1.1: +4 -2 lines
Changed semantics of unix-current-directory, so had to change
default-directory, which used it.
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;; ### Some day fix to accept :wild in any pathname component.
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10 wlott 1.2.1.2 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/filesys.lisp,v 1.2.1.2 1990/05/26 22:58:18 wlott Exp $
11     ;;;
12 ram 1.1 ;;; Ugly pathname functions for Spice Lisp.
13     ;;; these functions are part of the standard Spice Lisp environment.
14     ;;;
15     ;;; Written by Jim Large and Rob MacLachlan
16     ;;;
17     ;;; **********************************************************************
18 ram 1.2
19     (in-package "LISP")
20    
21 ram 1.1 (export '(pathname pathnamep *default-pathname-defaults* truename
22     parse-namestring merge-pathnames make-pathname
23     pathname-host pathname-device pathname-directory
24     pathname-name pathname-type pathname-version
25     namestring file-namestring directory-namestring
26     host-namestring enough-namestring user-homedir-pathname
27     probe-file rename-file delete-file file-write-date
28     file-author directory))
29    
30     (use-package "EXTENSIONS")
31    
32     (in-package "EXTENSIONS")
33     (export '(print-directory complete-file ambiguous-files default-directory
34     file-writable))
35 ram 1.2 (in-package "LISP")
36 ram 1.1
37    
38     ;;; Pathname structure
39    
40    
41     ;;; *Default-Pathname-defaults* has all values unspecified except for the
42     ;;; host. All pathnames must have a host.
43     (defvar *default-pathname-defaults* ()
44     "Set to the default pathname-defaults pathname (Got that?)")
45    
46     (defun filesys-init ()
47     (setq *default-pathname-defaults*
48     (%make-pathname "Mach" nil nil nil nil nil)))
49    
50    
51     ;;; The pathname type is defined with a defstruct.
52     ;;; This declaration implicitly defines the common lisp function Pathnamep
53     (defstruct (pathname
54     (:conc-name %pathname-)
55     (:print-function %print-pathname)
56     (:constructor
57     %make-pathname (host device directory name type version))
58     (:predicate pathnamep))
59     "Pathname is the structure of the file pathname. It consists of a
60     host, a device, a directory, a name, and a type."
61     (host nil :type (or simple-string null))
62     (device nil :type (or simple-string (member nil :absolute)))
63     (directory nil :type (or simple-vector null))
64     (name nil :type (or simple-string null))
65     (type nil :type (or simple-string null))
66     (version nil :type (or integer (member nil :newest))))
67    
68     (defun %print-pathname (s stream d)
69     (declare (ignore d))
70     (format stream "#.(pathname ~S)" (namestring s)))
71    
72     (defun make-pathname (&key defaults (host nil hostp) (device nil devicep)
73     (directory nil directoryp) (name nil namep)
74     (type nil typep) (version nil versionp))
75     "Create a pathname from :host, :device, :directory, :name, :type and :version.
76     If any field is ommitted, it is obtained from :defaults as though by
77     merge-pathnames."
78     (if defaults
79     (let ((defaults (pathname defaults)))
80     (unless hostp
81     (setq host (%pathname-host defaults)))
82     (unless devicep
83     (setq device (%pathname-device defaults)))
84     (unless directoryp
85     (setq directory (%pathname-directory defaults)))
86     (unless namep
87     (setq name (%pathname-name defaults)))
88     (unless typep
89     (setq type (%pathname-type defaults)))
90     (unless versionp
91     (setq version (%pathname-version defaults))))
92     (unless hostp
93     (setq host (%pathname-host *default-pathname-defaults*))))
94    
95     (when (stringp directory)
96     (setq directory (%pathname-directory (parse-namestring directory))))
97     (%make-pathname
98     (if (stringp host) (coerce host 'simple-string) host)
99     (if (stringp device) (coerce device 'simple-string) device)
100     directory
101     (if (stringp name) (coerce name 'simple-string) name)
102     (if (stringp type) (coerce type 'simple-string) type)
103     version))
104    
105    
106     ;;; These can not be done by the accessors because the pathname arg may be
107     ;;; a string or a symbol or etc.
108    
109     (defun pathname-host (pathname)
110     "Returns the host slot of pathname. Pathname may be a string, symbol,
111     or stream."
112     (%pathname-host (if (pathnamep pathname) pathname (pathname pathname))))
113    
114     (defun pathname-device (pathname)
115     "Returns the device slot of pathname. Pathname may be a string, symbol,
116     or stream."
117     (%pathname-device (if (pathnamep pathname) pathname (pathname pathname))))
118    
119     (defun pathname-directory (pathname)
120     "Returns the directory slot of pathname. Pathname may be a string,
121     symbol, or stream."
122     (%pathname-directory (if (pathnamep pathname) pathname (pathname pathname))))
123    
124     (defun pathname-name (pathname)
125     "Returns the name slot of pathname. Pathname may be a string,
126     symbol, or stream."
127     (%pathname-name (if (pathnamep pathname) pathname (pathname pathname))))
128    
129     (defun pathname-type (pathname)
130     "Returns the type slot of pathname. Pathname may be a string,
131     symbol, or stream."
132     (%pathname-type (if (pathnamep pathname) pathname (pathname pathname))))
133    
134     (defun pathname-version (pathname)
135     "Returns the version slot of pathname. Pathname may be a string,
136     symbol, or stream."
137     (%pathname-version (if (pathnamep pathname) pathname (pathname pathname))))
138    
139    
140    
141 ram 1.2 ;;;; PARSE-NAMESTRING and PATHNAME.
142 ram 1.1
143 ram 1.2 ;;; SPLIT-FILENAME -- internal
144     ;;;
145     ;;; Splits the filename into the name and type. If someone wants to change
146     ;;; this yet again, just change this.
147     ;;;
148     (defun split-filename (filename)
149     (declare (simple-string filename))
150     (let ((posn (position #\. filename :from-end t)))
151     (cond ((null posn)
152     (values filename nil))
153     ((or (zerop posn) (= posn (1- (length filename))))
154     (values filename ""))
155     (t
156     (values (subseq filename 0 posn)
157     (subseq filename (1+ posn)))))))
158 ram 1.1
159 ram 1.2 ;;; DO-FILENAME-PARSE -- internal
160 ram 1.1 ;;;
161 ram 1.2 ;;; Split string into a logical name, a vector of directories, a file name and
162     ;;; a file type.
163 ram 1.1 ;;;
164 ram 1.2 (defun do-filename-parse (string &optional (start 0) end)
165     (declare (simple-string string))
166     (let ((end (or end (length string))))
167     (let* ((directories nil)
168     (filename nil)
169     (absolutep (and (> end start) (eql (schar string start) #\/)))
170     (logical-name
171     (cond (absolutep
172     (setf start (position #\/ string :start start :end end
173     :test-not #'char=))
174     :absolute)
175     ((find #\: string
176     :start start
177     :end (or (position #\/ string :start start :end end)
178     end))
179     (let ((posn (position #\: string :start start)))
180     (prog1
181     (subseq string start posn)
182     (setf start (1+ posn))))))))
183     (loop
184     (unless (and start (> end start))
185     (return))
186     (let ((next-slash (position #\/ string :start start :end end)))
187     (cond (next-slash
188     (push (subseq string start next-slash) directories)
189     (setf start
190     (position #\/ string :start next-slash :end end
191     :test-not #'char=)))
192     (t
193     (setf filename (subseq string start end))
194     (return)))))
195     (multiple-value-bind (name type)
196     (if filename (split-filename filename))
197     (values (cond (logical-name logical-name)
198     (directories "Default"))
199     (if (or logical-name directories)
200     (coerce (nreverse directories) 'vector))
201     name
202     type)))))
203 ram 1.1
204 ram 1.2 (defun parse-namestring (thing &optional host
205     (defaults *default-pathname-defaults*)
206     &key (start 0) end junk-allowed)
207     "Convert THING (string, symbol, pathname, or stream) into a pathname."
208     (declare (ignore junk-allowed))
209     (let* ((host (or host (pathname-host defaults)))
210     (pathname
211     (etypecase thing
212     ((or string symbol)
213     (let ((string (coerce (string thing) 'simple-string)))
214     (multiple-value-bind (device directories name type)
215     (do-filename-parse string start end)
216     (unless end (setf end (length string)))
217     (make-pathname :host host
218     :device device
219     :directory directories
220     :name name
221     :type type))))
222     (pathname
223     (setf end start)
224     thing)
225     (stream
226     (setf end start)
227     (pathname (file-name thing))))))
228     (unless (or (null host)
229     (null (pathname-host pathname))
230     (string-equal host (pathname-host pathname)))
231     (cerror "Ignore it."
232     "Host mismatch in ~S: ~S isn't ~S"
233     'parse-namestring
234     (pathname-host pathname)
235     host))
236     (values pathname end)))
237 ram 1.1
238    
239     (defun pathname (thing)
240     "Turns thing into a pathname. Thing may be a string, symbol, stream, or
241     pathname."
242     (values (parse-namestring thing)))
243    
244    
245    
246     ;;; Merge-Pathnames -- Public
247     ;;;
248     ;;; Returns a new pathname whose fields are the same as the fields in PATHNAME
249     ;;; except that () fields are filled in from defaults. Type and Version field
250     ;;; are only done if name field has to be done (see manual for explanation).
251     ;;;
252     (defun merge-pathnames (pathname &optional
253     (defaults *default-pathname-defaults*)
254     default-version)
255     "Fills in unspecified slots of Pathname from Defaults (defaults to
256     *default-pathname-defaults*). If the version remains unspecified,
257     gets it from Default-Version."
258     ;;
259     ;; finish hairy argument defaulting
260     (setq pathname (pathname pathname))
261     (setq defaults (pathname defaults))
262     ;;
263     ;; make a new pathname
264     (let ((name (%pathname-name pathname))
265     (device (%pathname-device pathname)))
266     (%make-pathname
267     (or (%pathname-host pathname) (%pathname-host defaults))
268     (or device (%pathname-device defaults))
269     (or (%pathname-directory pathname) (%pathname-directory defaults))
270     (or name (%pathname-name defaults))
271     (or (%pathname-type pathname) (%pathname-type defaults))
272     (or (%pathname-version pathname)
273     (if name
274     default-version
275     (or (%pathname-version defaults) default-version))))))
276    
277    
278     ;;;; NAMESTRING and other stringification stuff.
279    
280     ;;; %Dirstring -- Internal
281     ;;;
282     ;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a
283     ;;; string of the form "foo/bar/ ... /baz/"
284    
285     (defun %dirstring (dirlist)
286     (declare (simple-vector dirlist))
287     (let* ((numdirs (length dirlist))
288     (length numdirs))
289     (declare (fixnum numdirs length))
290     (dotimes (i numdirs)
291     (incf length (the fixnum (length (svref dirlist i)))))
292     (do ((result (make-string length))
293     (index 0 (1+ index))
294     (position 0))
295     ((= index numdirs) result)
296     (declare (simple-string result))
297     (let* ((string (svref dirlist index))
298     (len (length string))
299     (end (+ position len)))
300     (declare (simple-string string)
301     (fixnum len end))
302     (replace result string :start1 position :end1 end :end2 len)
303     (setf (schar result end) #\/)
304     (setq position (+ end 1))))))
305    
306     (defun quick-integer-to-string (n)
307     (cond ((zerop n) "0")
308     ((eql n 1) "1")
309     ((minusp n)
310     (concatenate 'simple-string "-"
311     (the simple-string (quick-integer-to-string (- n)))))
312     (t
313     (do* ((len (1+ (truncate (integer-length n) 3)))
314     (res (make-string len))
315     (i (1- len) (1- i))
316     (q n)
317     (r 0))
318     ((zerop q)
319     (incf i)
320     (replace res res :start2 i :end2 len)
321 wlott 1.2.1.1 (shrink-vector res (- len i)))
322 ram 1.1 (declare (simple-string res)
323     (fixnum len i r))
324     (multiple-value-setq (q r) (truncate q 10))
325     (setf (schar res i) (schar "0123456789" r))))))
326    
327     (defun %device-string (device)
328     (cond ((eq device :absolute) "/")
329     (device
330     (if (string-equal device "Default")
331     ""
332     (concatenate 'simple-string (the simple-string device) ":")))
333     (T "")))
334    
335     (defun namestring (pathname)
336     "Returns the full form of PATHNAME as a string."
337     (setq pathname (pathname pathname))
338     (let* ((directory (%pathname-directory pathname))
339     (name (%pathname-name pathname))
340     (type (%pathname-type pathname))
341     (result (%device-string (%pathname-device pathname))))
342     (declare (simple-string result))
343     (when directory
344     (setq result (concatenate 'simple-string result
345     (the simple-string (%dirstring directory)))))
346     (when name
347     (setq result (concatenate 'simple-string result
348     (the simple-string name))))
349 ram 1.2 (when (and type (not (zerop (length type))))
350 ram 1.1 (setq result (concatenate 'simple-string result "."
351     (the simple-string type))))
352     result))
353    
354     (defun %ses-get-useful-name (pathname)
355     "NAMESTRING of pathname ignoring the device slot."
356     (setq pathname (pathname pathname))
357     (let* ((directory (%pathname-directory pathname))
358     (name (%pathname-name pathname))
359     (type (%pathname-type pathname))
360     (result ""))
361     (declare (simple-string result))
362     (when directory
363     (setq result (concatenate 'simple-string result
364     (the simple-string (%dirstring directory)))))
365     (when name
366     (setq result (concatenate 'simple-string result
367     (the simple-string name))))
368 ram 1.2 (when (and type (not (zerop (length type))))
369 ram 1.1 (setq result (concatenate 'simple-string result "."
370     (the simple-string type))))
371     result))
372    
373     ;;; This function is somewhat bummed to make the Hemlock directory command
374     ;;; is fast.
375     ;;;
376     (defun file-namestring (pathname)
377     "Returns the name, type, and version of PATHNAME as a string."
378     (unless (pathnamep pathname) (setq pathname (pathname pathname)))
379     (let* ((name (%pathname-name pathname))
380     (type (%pathname-type pathname))
381     (result (or name "")))
382     (declare (simple-string result))
383 ram 1.2 (if (and type (not (zerop (length type))))
384 ram 1.1 (concatenate 'simple-string result "." type)
385     result)))
386    
387     (defun directory-namestring (pathname)
388     "Returns the device & directory parts of PATHNAME as a string."
389     (setq pathname (pathname pathname))
390     (let* ((directory (%pathname-directory pathname))
391     (result (%device-string (%pathname-device pathname))))
392     (declare (simple-string result))
393     (when directory
394     (setq result (concatenate 'simple-string result
395     (the simple-string (%dirstring directory)))))
396     result))
397    
398     (defun host-namestring (pathname)
399     "Returns the host part of PATHNAME as a string."
400     (setq pathname (pathname pathname))
401     (%pathname-host pathname))
402    
403    
404    
405     ;;;; ENOUGH-NAMESTRING
406    
407     (defun enough-namestring (pathname &optional
408     (defaults *default-pathname-defaults*))
409     "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS."
410     (setq pathname (pathname pathname))
411     (setq defaults (pathname defaults))
412     (let* ((device (%pathname-device pathname))
413     (directory (%pathname-directory pathname))
414     (name (%pathname-name pathname))
415     (type (%pathname-type pathname))
416     (result "")
417     (need-name nil))
418     (declare (simple-string result))
419     (when (and device (string-not-equal device (%pathname-device defaults)))
420     (setq result (%device-string device)))
421     (when (and directory
422     (not (equalp directory (%pathname-directory defaults))))
423     (setq result (concatenate 'simple-string result
424     (the simple-string (%dirstring directory)))))
425     (when (and name (string-not-equal name (%pathname-name defaults)))
426     (setq result (concatenate 'simple-string result
427     (the simple-string name))
428     need-name t))
429     (when (and type (or need-name
430     (string-not-equal type (%pathname-type defaults))))
431     (setq result (concatenate 'simple-string result "."
432     (the simple-string type))))
433     result))
434    
435    
436    
437     ;;;; TRUENAME and other stuff probing stuff.
438    
439     ;;; Truename -- Public
440     ;;;
441     ;;; Another silly file function trivially different from another function.
442     ;;;
443     (defun truename (pathname)
444     "Return the pathname for the actual file described by the pathname
445     An error is signalled if no such file exists."
446     (let ((result (probe-file pathname)))
447     (unless result
448     (error "The file ~S does not exist." (namestring pathname)))
449     result))
450    
451     ;;; Do-Search-List -- Internal
452     ;;;
453     ;;; Bind var in turn to each element of search list with the specifed
454     ;;; name.
455     ;;;
456     (defmacro do-search-list ((var name &optional exit-form) . body)
457     "Do-Search-List (Var Name [Exit-Form]) {Form}*"
458     `(dolist (,var (resolve-search-list ,name nil) ,exit-form)
459     (declare (simple-string ,var))
460     ,@body))
461    
462    
463     ;;; Sub-Probe-File -- Internal
464     ;;;
465     ;;; Does the work of Probe-File, returning an additional value which
466     ;;; indicates whether the name is really a file.
467     ;;;
468     (defun sub-probe-file (pathname)
469     (setq pathname (pathname pathname))
470     (flet ((pathnamify (ns etype)
471     (declare (simple-string ns))
472     (case etype
473     (:entry_remote
474     (values (parse-namestring (concatenate 'simple-string ns "/"))
475     :entry_directory))
476     (t
477     (values (parse-namestring ns) etype)))))
478     (let ((log-name (or (%pathname-device pathname) "default")))
479     (if (eq log-name :absolute)
480     (let ((namestring (namestring pathname)))
481     (multiple-value-bind (name etype)
482     (mach:unix-subtestname namestring)
483     (if (null name) NIL
484     (pathnamify name etype))))
485     (if (null (%pathname-device pathname))
486     (multiple-value-bind (name etype)
487     (mach:unix-subtestname
488     (%ses-get-useful-name pathname))
489     (if (null name) NIL (pathnamify name etype)))
490     (let ((namestring (%ses-get-useful-name pathname)))
491     (do-search-list (entry log-name)
492     (let ((str (concatenate 'simple-string entry namestring)))
493     (declare (simple-string str))
494     (multiple-value-bind (name etype)
495     (mach:unix-subtestname str)
496     (when name
497     (return (pathnamify name etype))))))))))))
498    
499    
500     ;;; Probe-File -- Public
501     ;;;
502     ;;; Just call Sub-Probe-File and return nil when it isn't a file.
503     ;;;
504     (defun probe-file (pathname)
505     "Return a pathname which is the truename of the file if it exists, NIL
506     otherwise. Returns NIL for directories and other non-file entries."
507     (multiple-value-bind (pn f)
508     (sub-probe-file pathname)
509     (if (eq f :entry_file) pn)))
510    
511    
512    
513     ;;; Predict-Name -- Internal
514     ;;;
515     ;;; Predict-Name is a function used by Open to get an absolute pathname
516     ;;; for a file being opened. Returns the truename of the file and
517     ;;; whether it really exists or not.
518     ;;;
519     (defun predict-name (file-name for-input)
520     (let* ((pathname (pathname file-name))
521     (device (%pathname-device pathname))
522     (truename (probe-file pathname)))
523     (cond ((eq device :absolute)
524     (if truename
525     (values (namestring truename) t)
526     ;; Try again in case file-name is a directory.
527     (predict-name-with-subtest (namestring pathname))))
528     ((and for-input truename)
529     (values (namestring truename) t))
530     (t
531     (let ((expansion (resolve-search-list (or device "default") t)))
532     (let ((name (concatenate 'simple-string (car expansion)
533     (%ses-get-useful-name pathname))))
534     (declare (simple-string name))
535     (predict-name-with-subtest name)))))))
536    
537     (defun predict-name-with-subtest (name)
538     (let ((gr (mach:unix-subtestname name)))
539     (if gr
540     (values gr t)
541     (values (mach::simplify-file-name name) nil))))
542    
543    
544    
545     ;;; Rename-File -- Public
546     ;;;
547     ;;; If File is a File-Stream, then rename the associated file if it exists,
548     ;;; otherwise just change the name in the stream. If not a file stream, then
549     ;;; just rename the file.
550     ;;;
551     (defun rename-file (file new-name)
552     "Rename File to have the specified New-Name. If file is a stream open to a
553     file, then the associated file is renamed. If the file does not yet exist
554     then the file is created with the New-Name when the stream is closed."
555     (if (streamp file)
556     (let* ((name (file-name file))
557     (pn (parse-namestring name))
558     (npn (merge-pathnames new-name pn))
559     (new (predict-name npn nil)))
560     (when (mach:quick-subtestname name)
561     (multiple-value-bind (res err) (mach:Unix-rename name new)
562     (if (null res) (error "Failed to rename ~A to ~A, unix error: ~A."
563     name new (mach:get-unix-error-msg err)))))
564     (file-name file new)
565     (values npn pn (parse-namestring new)))
566     (let* ((pn (or (sub-probe-file file)
567     (error "File to rename does not exist: ~S" file)))
568     (npn (merge-pathnames new-name pn))
569     (new (predict-name npn nil)))
570     (multiple-value-bind (res err) (mach:unix-rename (namestring pn) new)
571     (if res (values npn pn (parse-namestring new))
572     (error "Failed to rename ~A to ~A, unix error: ~A."
573     (namestring pn) new (mach:get-unix-error-msg err)))))))
574    
575     ;;; Delete-File -- Public
576     ;;;
577     ;;; Delete the file, Man.
578     ;;;
579     (defun delete-file (file)
580     "Delete the specified file."
581     (let ((tn (sub-probe-file file)))
582     (when (streamp file)
583     (close file :abort t))
584     (if tn
585     (let ((ns (namestring tn)))
586     (multiple-value-bind (res err) (mach:unix-unlink ns)
587     (if (null res)
588     (error "Failed to delete ~A, unix error: ~A."
589     ns (mach:get-unix-error-msg err)))))
590     (unless (streamp file)
591     (error "File to be deleted does not exist: ~S" file))))
592     t)
593    
594     ;;; User-Homedir-Pathname -- Public
595     ;;;
596     ;;; If the user wants a meaningful homedir, she has to define Home:.
597     ;;; Someday, login may do this for us. Since we must always return something,
598     ;;; we just return Default: if it isn't defined.
599     ;;;
600     (defun user-homedir-pathname (&optional host)
601     "Returns the home directory of the logged in user as a pathname.
602     This is obtained from the logical name \"home:\". If this is not defined,
603     then we return \"default:\""
604     (declare (ignore host))
605     (let ((home (cdr (assoc :home *environment-list* :test #'eq))))
606     (if home
607     (pathname (if (string-equal home "/") "/"
608     (concatenate 'simple-string home "/")))
609     (let ((expansion (if (search-list "home:")
610     (resolve-search-list "home" t))))
611     (if expansion
612     (car expansion)
613     (make-pathname :device "default"))))))
614    
615     ;;; File-Write-Date -- Public
616     ;;;
617     (defun file-write-date (file)
618     "Return file's creation date, or NIL if it doesn't exist."
619     (let ((tn (sub-probe-file file)))
620     (when tn
621     (multiple-value-bind (res dev ino mode nlink uid gid
622     rdev size atime mtime)
623     (mach:unix-stat (namestring tn))
624     (declare (ignore dev ino mode nlink uid gid rdev size atime))
625     (if (null res) 0
626     (+ unix-to-universal-time mtime))))))
627    
628     ;;; File-Author -- Public
629     ;;;
630     (defun file-author (file)
631     "Returns the file author as a string, or nil if the author cannot be
632     determined. Signals an error if file doesn't exist."
633     (let ((filename (truename file)))
634     (multiple-value-bind (winp dev ino mode nlink uid)
635     (mach:unix-stat (namestring filename))
636     (declare (ignore dev ino mode nlink))
637     (if winp (lookup-login-name uid)))))
638    
639    
640    
641     ;;;; DIRECTORY.
642    
643     ;;; DO-DIRECTORY searches a directory, binding the vars to the name and entry
644     ;;; type. Pattern and All are used in MACH:UNIX-SEARCH-DIRECTORY.
645     ;;;
646     (defmacro do-directory ((name-var etype-var pattern &optional (all t) result)
647     . body)
648     "Do-Directory (Name Entry-Type Pattern [All] [Result]) {Form}*.
649     If All is non-nil (the default), then Unix dot files to be processed.
650     Unix dot and dot-dot are never processed."
651     (let ((file (gensym))
652     (res (gensym))
653     (type (gensym))
654     (p (gensym)))
655     `(dolist (,file (mach:unix-search-directory ,pattern ,all)
656     ,result)
657     (declare (simple-string ,file))
658     (let* ((,p (position #\/ ,file :from-end t))
659     (,name-var
660     (if ,p
661     (subseq ,file (the fixnum (1+ (the fixnum ,p))))
662     ,file)))
663     (declare (simple-string ,name-var))
664     (unless (or (string= "." ,name-var) (string= ".." ,name-var))
665     (let ((,etype-var (multiple-value-bind (,res ,type)
666     (mach:quick-subtestname ,file)
667     (declare (ignore ,res))
668     ,type)))
669     ,@body))))))
670    
671     (defun directory (pathname &key (all t))
672     "Returns a list of pathnames, one for each file that matches the given
673     pathname. Supplying :all as nil causes this to ignore Unix dot files. This
674     never includes Unix dot and dot-dot in the result."
675     (setq pathname (pathname pathname))
676     (multiple-value-bind (dir pattern) (find-directory pathname)
677     (let ((res ()))
678     (do-directory (name etype pattern all)
679     (if (eq etype :entry_file)
680     (let ((last-dot (position #\. name :from-end t)))
681     (push
682     (%make-pathname
683     "Mach" :absolute dir
684     (if last-dot (subseq name 0 last-dot) name)
685     (if last-dot (subseq name (1+ last-dot)))
686     nil)
687     res))
688     (push
689     (%make-pathname
690     "Mach" :absolute
691     (concatenate 'simple-vector dir (vector name))
692     nil nil nil)
693     res)))
694     (nreverse res))))
695    
696     ;;; FIND-DIRECTORY returns an absolute directory vector for pathname as a
697     ;;; first argument and an absolute namestring. The namestring includes a
698     ;;; trailing asterisk, wildcard, when the given pathname is immediately
699     ;;; probe-able as a directory.
700     ;;;
701     (defun find-directory (pathname)
702     (multiple-value-bind (pn type)
703     (sub-probe-file pathname)
704     (if pn
705     (let ((ns (namestring pn)))
706     (declare (simple-string ns))
707     (case type
708     (:entry_directory
709     (when (char/= (schar ns (the fixnum (1- (length ns)))) #\/)
710     (setq ns (concatenate 'simple-string ns "/")))
711     (values (%pathname-directory (pathname ns))
712     (concatenate 'simple-string ns "*")))
713     (t (values (%pathname-directory pn) ns))))
714     (multiple-value-bind (pn type)
715     (sub-probe-file
716     (make-pathname
717     :directory (%pathname-directory pathname)
718     :device (%pathname-device pathname)))
719     (unless pn
720     (error "Directory does not exist: ~S" pathname))
721     (let ((ns (namestring pn)))
722     (case type
723     (:entry_directory
724     (values
725     (%pathname-directory pn)
726     (concatenate 'simple-string ns (file-namestring pathname))))
727     (t
728     (error "~S is not a directory." pathname))))))))
729    
730    
731    
732     ;;;; Printing directories and determining file owner names.
733    
734     ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
735     ;;;
736     (defun print-directory (pathname &optional stream &key all verbose return-list)
737     "Like Directory, but prints a terse, multi-coloumn directory listing
738     instead of returning a list of pathnames. When :all is supplied and
739     non-nil, then Unix dot files are included too (as ls -a). When :vervose
740     is supplied and non-nil, then a long listing of miscellaneous
741     information is output one file per line."
742     (setf pathname (pathname pathname))
743     (let ((*standard-output* (out-synonym-of stream)))
744     (if verbose
745     (print-directory-verbose pathname all return-list)
746     (print-directory-formatted pathname all return-list))))
747    
748     (defun print-directory-verbose (pathname all return-list)
749     (multiple-value-bind (dir pattern) (find-directory pathname)
750     (declare (ignore dir))
751     (format t "Directory of ~A :~%" pattern)
752     (let ((dir-name (directory-namestring pattern))
753     (result ()))
754     (do-directory (name etype pattern all (nreverse result))
755     (let ((slash-name (if (eq etype :entry_file)
756     name
757     (concatenate 'simple-string name "/"))))
758     (declare (simple-string slash-name))
759     (when return-list
760     (push (pathname (concatenate 'simple-string dir-name slash-name))
761     result))
762     (multiple-value-bind
763     (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
764     (mach:unix-stat (concatenate 'simple-string dir-name name))
765     (declare (ignore ino gid rdev atime)
766     (fixnum uid mode))
767     (cond (reslt
768     ;;
769     ;; Print characters for file modes.
770     (macrolet ((frob (bit name &optional sbit sname negate)
771     `(if ,(if negate
772     `(not (logbitp ,bit mode))
773     `(logbitp ,bit mode))
774     ,(if sbit
775     `(if (logbitp ,sbit mode)
776     (write-char ,sname)
777     (write-char ,name))
778     `(write-char ,name))
779     (write-char #\-))))
780     (frob 15 #\d nil nil t)
781     (frob 8 #\r)
782     (frob 7 #\w)
783     (frob 6 #\x 11 #\s)
784     (frob 5 #\r)
785     (frob 4 #\w)
786     (frob 3 #\x 10 #\s)
787     (frob 2 #\r)
788     (frob 1 #\w)
789     (frob 0 #\x))
790     ;;
791     ;; Print the rest.
792     (multiple-value-bind (sec min hour date month year)
793     (get-decoded-time)
794     (declare (ignore sec min hour date month))
795     (format t "~2D ~8A ~8D ~12A ~A~%"
796     nlink
797     (or (lookup-login-name uid) uid)
798     size
799     (decode-universal-time-for-files mtime year)
800     slash-name)))
801     (t (format t "Couldn't stat ~A -- ~A.~%"
802     slash-name
803     (mach:get-unix-error-msg dev-or-err))))))))))
804    
805     (defun decode-universal-time-for-files (time current-year)
806     (multiple-value-bind (sec min hour day month year)
807     (decode-universal-time (+ time unix-to-universal-time))
808     (declare (ignore sec))
809     (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
810     (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
811     "Sep" "Oct" "Nov" "Dec")
812     (1- month))
813     day (= current-year year) year hour min)))
814    
815     (defun print-directory-formatted (pathname all return-list)
816     (let ((width (or (line-length *standard-output*) 80))
817     (names ())
818     (cnt 0)
819     (max-len 0)
820     (result ()))
821     (declare (list names) (fixnum max-len cnt))
822     ;;
823     ;; Get the data.
824     (multiple-value-bind (dir pattern) (find-directory pathname)
825     (declare (ignore dir))
826     (do-directory (name etype pattern all)
827     (let* ((slash-name (if (eql etype :entry_file)
828     name
829     (concatenate 'simple-string name "/")))
830     (len (length slash-name)))
831     (declare (simple-string slash-name)
832     (fixnum len))
833     (when return-list
834     (push (pathname (concatenate 'simple-string
835     (directory-namestring pattern)
836     slash-name))
837     result))
838    
839     (if (> len max-len) (setq max-len len))
840     (incf cnt)
841     (push slash-name names)))
842     (setq names (nreverse names))
843     ;;
844     ;; Do the output.
845     (let* ((col-width (1+ max-len))
846     (cols (max (truncate width col-width) 1))
847     (lines (ceiling cnt cols)))
848     (declare (fixnum cols lines))
849     (format t "Directory of ~A :~%" pattern)
850     (dotimes (i lines)
851     (declare (fixnum i))
852     (dotimes (j cols)
853     (declare (fixnum j))
854     (let ((name (nth (+ i (the fixnum (* j lines))) names)))
855     (when name
856     (write-string name)
857     (unless (eql j (1- cols))
858     (tab-over
859     (- col-width (length (the simple-string name))))))))
860     (terpri))))
861     (when return-list (nreverse result))))
862    
863    
864    
865     ;;;; Translating uid's and gid's.
866    
867     (defvar *uid-hash-table* (make-hash-table)
868     "Hash table for keeping track of uid's and login names.")
869    
870     ;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous
871     ;;; lookups are cached in a hash table since groveling the passwd(s) files
872     ;;; is somewhat expensive. The table may hold nil for id's that cannot
873     ;;; be looked up since this means the files are searched in their entirety
874     ;;; each time this id is translated.
875     ;;;
876     (defun lookup-login-name (uid)
877     (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
878     (if foundp
879     login-name
880     (setf (gethash uid *uid-hash-table*)
881     (get-group-or-user-name :user uid)))))
882    
883     (defvar *gid-hash-table* (make-hash-table)
884     "Hash table for keeping track of gid's and group names.")
885    
886     ;;; LOOKUP-GROUP-NAME translates a group id into a group name. Previous
887     ;;; lookups are cached in a hash table since groveling the group(s) files
888     ;;; is somewhat expensive. The table may hold nil for id's that cannot
889     ;;; be looked up since this means the files are searched in their entirety
890     ;;; each time this id is translated.
891     ;;;
892     (defun lookup-group-name (gid)
893     (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*)
894     (if foundp
895     group-name
896     (setf (gethash gid *gid-hash-table*)
897     (get-group-or-user-name :group gid)))))
898    
899    
900     ;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is
901     ;;; a much smaller file, contains all the local id's, and most uses probably
902     ;;; involve id's on machines one would login into. Then if necessary, we look
903     ;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be
904     ;;; fetched over the net.
905     ;;;
906     (defun get-group-or-user-name (group-or-user id)
907     "Returns the simple-string user or group name of the user whose uid or gid
908     is id, or NIL if no such user or group exists. Group-or-user is either
909     :group or :user."
910     (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
911     (declare (simple-string id-string))
912     (multiple-value-bind (file1 file2)
913     (ecase group-or-user
914     (:group (values "/etc/group" "/etc/groups"))
915     (:user (values "/etc/passwd" "/etc/passwd")))
916     (or (get-group-or-user-name-aux id-string file1)
917     (get-group-or-user-name-aux id-string file2)))))
918    
919     (defun get-group-or-user-name-aux (id-string passwd-file)
920     (with-open-file (stream passwd-file)
921     (loop
922     (let ((entry (read-line stream nil)))
923     (unless entry (return nil))
924     (let ((name-end (position #\: (the simple-string entry)
925     :test #'char=)))
926     (when name-end
927     (let ((id-start (position #\: (the simple-string entry)
928     :start (1+ name-end) :test #'char=)))
929     (when id-start
930     (incf id-start)
931     (let ((id-end (position #\: (the simple-string entry)
932     :start id-start :test #'char=)))
933     (when (and id-end
934     (string= id-string entry
935     :start2 id-start :end2 id-end))
936     (return (subseq entry 0 name-end))))))))))))
937    
938    
939    
940     ;;; Complete-One-File -- Internal
941     ;;;
942     ;;; Return as values a string and the greatest common prefix of all
943     ;;; the files corresponding to pattern.
944     ;;;
945     (defun complete-one-file (pattern default-type ignore-types)
946     (let ((first nil)
947     (length nil))
948     (do-directory (name etype pattern nil)
949     (declare (ignore etype))
950     (let* ((last-dot (position #\. name :from-end t))
951     (type (if last-dot (subseq name (1+ last-dot)))))
952     (cond ((and (not (string= type default-type))
953     (member type ignore-types :test #'string=)))
954     (first
955     (let ((msm (string-not-equal name first :end2 length)))
956     (when (and msm (< msm length))
957     (setq length msm))))
958     (t
959     (setq first name)
960     (setq length (length name))))))
961     (values first length)))
962    
963    
964     ;;; Complete-File -- Public
965     ;;;
966     ;;; If the pathname is absolute, just call Complete-One-File on and test
967     ;;; whether the result is a file. If a relative pathname, do it on each
968     ;;; directory, accumulating the result.
969     ;;;
970     (defun complete-file (pathname &key defaults ignore-types)
971     "Attempt to complete Pathname as the name of a file. If the resulting
972     completion is unique, return T as the second value. If there is no
973     possible completion, return both values NIL."
974     (setq pathname (pathname pathname))
975     (setq defaults (if defaults (pathname defaults) *default-pathname-defaults*))
976     (flet ((pathnamify (res len ambiguous pathname)
977     (values
978     (make-pathname :device (%pathname-device pathname)
979     :directory (%pathname-directory pathname)
980     :defaults (parse-namestring (subseq res 0 len)))
981     (not ambiguous))))
982     (let ((dev (or (%pathname-device pathname) "default"))
983     (default-type (%pathname-type defaults)))
984     (if (eq dev :absolute)
985     (multiple-value-bind
986     (res len)
987     (complete-one-file (concatenate 'simple-string
988     (namestring pathname)
989     "*")
990     default-type ignore-types)
991     (declare (fixnum len))
992     (if res
993     (pathnamify res len
994     (/= (the fixnum (length res)) len)
995     pathname)
996     (values nil nil)))
997     (let ((namestring (%ses-get-useful-name pathname))
998     (dirs (if (and (%pathname-directory defaults)
999     (string-equal dev "default"))
1000     (list (directory-namestring defaults))
1001     ()))
1002     (max most-positive-fixnum)
1003     (max-str nil)
1004     (ambiguous nil))
1005     (declare (simple-string namestring))
1006     (do-search-list (entry dev)
1007     (pushnew entry dirs :test #'string-equal))
1008     (dolist (entry dirs)
1009     (let ((str (concatenate 'simple-string entry namestring "*")))
1010     (declare (simple-string str))
1011     (multiple-value-bind
1012     (res len)
1013     (complete-one-file str default-type ignore-types)
1014     (when res
1015     (unless ambiguous
1016     (setq ambiguous (or max-str (/= (length res) len))))
1017     (if max-str
1018     (setq max (or (string-not-equal res max-str :end1 len
1019     :end2 max)
1020     max))
1021     (setq max len max-str res))))))
1022     (if max-str
1023     (pathnamify max-str max ambiguous pathname)
1024     (values nil nil)))))))
1025    
1026     ;;; File-writable -- exported from extensions.
1027     ;;;
1028     ;;; Determines whether the single argument (which should be a pathname)
1029     ;;; can be written by the the current task.
1030    
1031     (defun file-writable (name)
1032     "File-writable accepts a pathname and returns T if the current
1033     process can write it, and NIL otherwise."
1034     (multiple-value-bind (tn exists) (predict-name name nil)
1035     (if exists
1036     (values (mach:unix-access tn mach:w_ok))
1037     (values (mach:unix-access (directory-namestring tn)
1038     (logior mach:w_ok mach:x_ok))))))
1039    
1040    
1041     ;;; Pathname-Order -- Internal
1042     ;;;
1043     ;;; Predicate to order pathnames by. Goes by name.
1044     ;;;
1045     (defun pathname-order (x y)
1046     (let ((xn (%pathname-name x))
1047     (yn (%pathname-name y)))
1048     (if (and xn yn)
1049     (let ((res (string-lessp xn yn)))
1050     (cond ((not res) nil)
1051     ((= res (length (the simple-string xn))) t)
1052     ((= res (length (the simple-string yn))) nil)
1053     (t t)))
1054     xn)))
1055    
1056     ;;; Ambiguous-Files -- Public
1057     ;;;
1058     ;;; If the pathname is absolute, just do a directory. If it is relative,
1059     ;;; do a directory on each directory in the search-list and merge the results.
1060     ;;;
1061     (defun ambiguous-files (pathname &optional defaults)
1062     "Return a list of all files which are possible completions of Pathname.
1063     We look in the directory specified by Defaults as well as looking down
1064     the search list."
1065     (setq pathname (pathname pathname)
1066     defaults (if defaults (pathname defaults) *default-pathname-defaults*))
1067     (let ((dev (or (%pathname-device pathname) "default")))
1068     (if (eq dev :absolute)
1069     (directory (concatenate 'simple-string (namestring pathname) "*"))
1070     (let ((namestring (%ses-get-useful-name pathname))
1071     (dirs (if (and (%pathname-directory defaults)
1072     (string-equal dev "default"))
1073     (list (directory-namestring defaults))
1074     ()))
1075     (res ()))
1076     (declare (simple-string namestring))
1077     (do-search-list (entry dev) (pushnew entry dirs :test #'string-equal))
1078     (dolist (entry dirs)
1079     (let ((str (concatenate 'simple-string entry namestring "*")))
1080     (declare (simple-string str))
1081     (setq res (merge 'list res (directory str)
1082     #'pathname-order))))
1083     res))))
1084    
1085     ;;; Default-Directory -- Public
1086     ;;;
1087     ;;; This fills in a hole in Common Lisp. We return the first thing we
1088     ;;; find by doing a ResolveSearchList on Default.
1089     ;;;
1090     (defun default-directory ()
1091     "Returns the pathname for the default directory. This is the place where
1092     a file will be written if no directory is specified. This may be changed
1093     with setf."
1094     (multiple-value-bind (gr dir-or-error)
1095     (mach:unix-current-directory)
1096     (if gr
1097 wlott 1.2.1.2 (pathname dir-or-error)
1098     (error dir-or-error))))
1099 ram 1.1
1100     ;;;
1101     ;;; Maybe this shouldn't go here...
1102     (defsetf default-directory %set-default-directory)
1103    
1104     ;;; %Set-Default-Directory -- Internal
1105     ;;;
1106     ;;; The setf method for Default-Directory. We actually set the environment
1107     ;;; variable Current which is by convention the head of the search list.
1108     ;;;
1109     (defun %set-default-directory (new-val)
1110     (multiple-value-bind (gr error)
1111     (mach:unix-chdir (predict-name new-val nil))
1112     (if gr
1113     (car (setf (search-list "default:")
1114     (cdr (multiple-value-list (mach:unix-current-directory)))))
1115     (error (mach:get-unix-error-msg error)))))

  ViewVC Help
Powered by ViewVC 1.1.5