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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5