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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5