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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5