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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5