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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5