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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5