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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.104.4.1 - (show annotations)
Wed May 14 16:12:04 2008 UTC (5 years, 11 months ago) by rtoy
Branch: unicode-utf16-branch
Changes since 1.104: +14 -4 lines
Initial checkin of unicode branch.  This is incomplete.

What works:
o Cross-compile works on sparc and a lisp.core is created.  This core
  is able to build code and appears to use 16-bit strings.

What doesn't:
o The sparc version is not able to rebuild itself.  It hangs when
  trying to create a new lisp.core.
o The x86 version will cross-compile, but worldload fails.  The files
  being loaded have bizarre names.  Probably some deftransform not
  working correctly.

Issues:
o Characters are still essentially 8 bits.  This needs to be fixed.
o All input/output is basically still 8 bits.  Only the low 8 bits of
  a character are output.  For input, characters are assumed to be
  8-bit.
o No external formats or anything is supported.
o Readtable support not done.


Use boot-2008-05-cross-unicode-{sparc,x86}.lisp to cross-compile the
unicode changes.

Untested whether this code can still be compiled without :unicode.

Changes:

code/array.lisp:
o Base-char strings are 16 bits wide, not 8.

code/c-call.lisp:
o Define versions of DEPORT-GEN, %NATURALIZE-C-STRING to "handle"
  unicode strings.

code/debug-info.lisp:
o Adjust READ-VAR-STRING to use 16-bit strings.  (Needed to at least
  to make the disassembler work.)

code/debug.lisp:
o Add address when printing out objects that can't be printed.
  (Generally useful and not just for unicode.)

code/fd-stream.lisp:
o Hack output routines to only use the low 8-bits of the character.
  (This needs significant work!)

code/filesys.lisp:
o Some debugging %primitive prints left in, but commented out, in
  PARSE-UNIX-NAMESTRING.

code/lispinit.lisp:
o Debugging %primitive print's for top-level forms.

code/load.lisp:
o Update FOP-SHORT-CHARACTER for unicode.  But still only output the
  low 8 bits of a character to a fasl/core.  This needs updating.
o Hack routines for symbols to explicitly read in the individual bytes
  of the symbol/package name because READ-N-BYTES isn't working for us
  right now.
o Update FOP-STRING/FOP-SMALL-STRING to read in 16-bit elements for
  strings.  Full 16-bit strings supported.
o Currently only write 8-bit chars for foreign names.  This needs
  fixing.

code/misc.lisp:
o Register :unicode runtime feature.

code/pathname.lisp:
o Debugging %primitive prints left in, but commented out.

code/stream.lisp:
o Replace %primitive byte-blt with REPLACE for now to get the desired
  characters.

code/unix-glibc2.lisp:
o Workaround for unix-current-directory to return 16-bit strings.
  (Not necessary anymore?)
o UNIX-RESOLVE-LINKS doesn't seem to like MAKE-STRING with an
  INITIAL-ELEMENT specified.  Remove initial-element.  (Needs fixing.)

code/unix.lisp:
o Same as for unix-glibc2.lisp

compiler/array-tran.lisp:
o Turn off the MAKE-STRING deftransform.
o Update ARRAY-INFO to create 16-bit arrays for an element-type of
  base-char.

compiler/dump.lisp:
o Only dump 8-bit chars to a fasl for foreign fixups.
o Explicitly dump the characters of symbol name.  DUMP-BYTES not quite
  working for us now?
o Make DUMP-SIMPLE-STRING dump all 16 bits of each character.
o Characters are dumped as the low 8 bits.  Needs fixing.

compiler/generic/new-genesis.lisp:
o STRING-TO-CORE writes 16-bit strings to the core file.
o FOP-SHORT-CHARACTER for unicode added, but we still only write 8
  bits to the core.  (Needs fixing.)
o COLD-LOAD-SYMBOL modified to read 16-bit characters from the fasl
  file to create a symbol.
o FOP-UNINTERNED-SYMBOL-SAVE and FOP-UNINTERNED-SMALL-SYMBOL-SAVE
  reads 16-bit characters for symbol names.
o FOP-STRING/FOP-SMALL-STRING reads 16-bit characters for strings.
o FOP-FOREIGN-FIXUP and FOP-FOREIGN-DATA-FIXUP still only read 8-bit
  characters for foreign names.  (Needs fixing.)

compiler/generic/vm-tran.lisp:
o New deftransforms to support unicode.  Not the most efficient but
  should be workable for now.  Old deftransforms didn't copy enough
  bits.
o Deftransform for concatenate completely disabled.  This needs
  fixing.

compiler/sparc/array.lisp:
o Change simple-string accessor to use halfword accessors instead of
  byte accessors.

compiler/x86/array.lisp:
o Change simple-string accessor to use halfword accessors instead of
  byte accessors.

lisp/Config.linux_gencgc:
o Define -DUNICODE as needed

lisp/Config.sun4_solaris_sunc
o Define -DUNICODE as needed.

lisp/alloc.c:
o alloc_string needs to allocate 16-bit strings

lisp/backtrace.c:
o Tell ldb backtrace how to print out 16-bit strings.  This is a hack!

lisp/gencgc.c:
o Tell GC how long the 16-bit strings are now.

lisp/interr.c:
o Not really needed but make debug_print (aka %primitive print)
  support all objects by calling ldb's print function to print the
  object.

lisp/os-common.c:
o Add hack convert_lisp_string to take a 16-bit Lisp string and create
  a new string containing just the low 8 bits of each Lisp character.
o OS foreign linkage stuff needs 8-bit strings, so we need to convert
  Lisp strings to the desired size.  Very hackish!

lisp/print.c:
o Teach ldb how to print Lisp 16-bit strings.  Currently, just dump
  out each byte of the 16-bit string.  This needs major work!

lisp/purify.c:
o Teach purify about the 16-bit strings.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;; **********************************************************************
3 ;;; This code was written as part of the CMU Common Lisp project at
4 ;;; Carnegie Mellon University, and has been placed in the public domain.
5 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
6 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
7 ;;;
8 (ext:file-comment
9 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/filesys.lisp,v 1.104.4.1 2008/05/14 16:12:04 rtoy Exp $")
10 ;;;
11 ;;; **********************************************************************
12 ;;;
13 ;;; File system interface functions. This file is pretty UNIX specific.
14 ;;;
15 ;;; Written by William Lott
16 ;;;
17 ;;; **********************************************************************
18
19 (in-package "LISP")
20
21 (export '(truename probe-file user-homedir-pathname directory
22 rename-file delete-file file-write-date file-author))
23
24 (use-package "EXTENSIONS")
25
26 (in-package "EXTENSIONS")
27 (export '(print-directory complete-file ambiguous-files default-directory
28 purge-backup-files file-writable unix-namestring))
29 (in-package "LISP")
30
31
32 ;;;; Unix pathname host support.
33
34 ;;; Unix namestrings have the following format:
35 ;;;
36 ;;; namestring := [ directory ] [ file [ type [ version ]]]
37 ;;; directory := [ "/" | search-list ] { file "/" }*
38 ;;; search-list := [^:/]*:
39 ;;; file := [^/]*
40 ;;; type := "." [^/.]*
41 ;;; version := ".*" | ".~" ([1-9]+[0-9]* | "*") "~"
42 ;;;
43 ;;; Note: this grammar is ambiguous. The string foo.bar.~5~ can be parsed
44 ;;; as either just the file specified or as specifying the file, type, and
45 ;;; version. Therefore, we use the following rules when confronted with
46 ;;; an ambiguous file.type.version string:
47 ;;;
48 ;;; - If the first character is a dot, it's part of the file. It is not
49 ;;; considered a dot in the following rules.
50 ;;;
51 ;;; - If there is only one dot, it separates the file and the type.
52 ;;;
53 ;;; - If there are multiple dots and the stuff following the last dot
54 ;;; is a valid version, then that is the version and the stuff between
55 ;;; the second to last dot and the last dot is the type.
56 ;;;
57 ;;; Wildcard characters:
58 ;;;
59 ;;; If the directory, file, type components contain any of the following
60 ;;; characters, it is considered part of a wildcard pattern and has the
61 ;;; following meaning.
62 ;;;
63 ;;; ? - matches any character
64 ;;; * - matches any zero or more characters.
65 ;;; [abc] - matches any of a, b, or c.
66 ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
67 ;;;
68 ;;; Any of these special characters can be preceded by a backslash to
69 ;;; cause it to be treated as a regular character.
70 ;;;
71
72 (defun remove-backslashes (namestr start end)
73 "Remove any occurrences of \\ from the string because we've already
74 checked for whatever may have been backslashed."
75 (declare (type simple-base-string namestr)
76 (type index start end))
77 (let* ((result (make-string (- end start)))
78 (dst 0)
79 (quoted nil))
80 (do ((src start (1+ src)))
81 ((= src end))
82 (cond (quoted
83 (setf (schar result dst) (schar namestr src))
84 (setf quoted nil)
85 (incf dst))
86 (t
87 (let ((char (schar namestr src)))
88 (cond ((char= char #\\)
89 (setq quoted t))
90 (t
91 (setf (schar result dst) char)
92 (incf dst)))))))
93 (when quoted
94 (error 'namestring-parse-error
95 :complaint "Backslash in bad place."
96 :namestring namestr
97 :offset (1- end)))
98 (shrink-vector result dst)))
99
100 (defvar *ignore-wildcards* nil
101 "If non-NIL, Unix shell-style wildcards are ignored when parsing
102 pathname namestrings. They are also ignored when computing
103 namestrings for pathname objects. Thus, *, ?, etc. are not
104 wildcards when parsing a namestring, and are not escaped when
105 printing pathnames.")
106
107 (defun maybe-make-pattern (namestr start end)
108 (declare (type simple-base-string namestr)
109 (type index start end))
110 (if *ignore-wildcards*
111 (subseq namestr start end)
112 (collect ((pattern))
113 (let ((quoted nil)
114 (any-quotes nil)
115 (last-regular-char nil)
116 (index start))
117 (flet ((flush-pending-regulars ()
118 (when last-regular-char
119 (pattern (if any-quotes
120 (remove-backslashes namestr
121 last-regular-char
122 index)
123 (subseq namestr last-regular-char index)))
124 (setf any-quotes nil)
125 (setf last-regular-char nil))))
126 (loop
127 (when (>= index end)
128 (return))
129 (let ((char (schar namestr index)))
130 (cond (quoted
131 (incf index)
132 (setf quoted nil))
133 ((char= char #\\)
134 (setf quoted t)
135 (setf any-quotes t)
136 (unless last-regular-char
137 (setf last-regular-char index))
138 (incf index))
139 ((char= char #\?)
140 (flush-pending-regulars)
141 (pattern :single-char-wild)
142 (incf index))
143 ((char= char #\*)
144 (flush-pending-regulars)
145 (pattern :multi-char-wild)
146 (incf index))
147 ((char= char #\[)
148 (flush-pending-regulars)
149 (let ((close-bracket
150 (position #\] namestr :start index :end end)))
151 (unless close-bracket
152 (error 'namestring-parse-error
153 :complaint "``['' with no corresponding ``]''"
154 :namestring namestr
155 :offset index))
156 (pattern (list :character-set
157 (subseq namestr
158 (1+ index)
159 close-bracket)))
160 (setf index (1+ close-bracket))))
161 (t
162 (unless last-regular-char
163 (setf last-regular-char index))
164 (incf index)))))
165 (flush-pending-regulars)))
166 (cond ((null (pattern))
167 "")
168 ((null (cdr (pattern)))
169 (let ((piece (first (pattern))))
170 (typecase piece
171 ((member :multi-char-wild) :wild)
172 (simple-string piece)
173 (t
174 (make-pattern (pattern))))))
175 (t
176 (make-pattern (pattern)))))))
177
178 ;;; extract-name-type-and-version -- Internal.
179 ;;;
180 (defun extract-name-type-and-version (namestr start end)
181 (declare (type simple-base-string namestr)
182 (type index start end))
183 (labels
184 ((explicit-version (namestr start end)
185 ;; Look for something like "~*~" at the end of the
186 ;; namestring, where * can be #\* or some digits. This
187 ;; denotes a version.
188 ;;(format t "explicit-version ~S ~A ~A~%" namestr start end)
189 (cond ((or (< (- end start) 4)
190 (and (char/= (schar namestr (1- end)) #\~)
191 (char/= (schar namestr (1- end)) #\*)))
192 ;; No explicit version given, so return NIL to
193 ;; indicate we don't want file versions, unless
194 ;; requested in other ways.
195 ;;(format t "case 1: ~A ~A~%" nil end)
196 (values nil end))
197 ((and (not *ignore-wildcards*)
198 (char= (schar namestr (- end 2)) #\*)
199 (char= (schar namestr (- end 3)) #\~)
200 (char= (schar namestr (- end 4)) #\.))
201 ;; Found "~*~", so it's a wild version
202 ;;(format t "case 2: ~A ~A~%" :wild (- end 4))
203 (values :wild (- end 4)))
204 (t
205 ;; Look for a version number. Start at the end, just
206 ;; before the ~ and keep looking for digits. If the
207 ;; first non-digit is ~, and the leading character is
208 ;; a non-zero digit, we have a version number, so get
209 ;; it. If not, we didn't find a version number, so we
210 ;; call it :newest
211 (do ((i (- end 2) (1- i)))
212 ((< i (+ start 1))
213 ;;(format t "case 3: ~A ~A~%" :newest end)
214 (values :newest end))
215 (let ((char (schar namestr i)))
216 (when (eql char #\~)
217 (return (if (char= (schar namestr (1- i)) #\.)
218 (if (char= (schar namestr (1+ i)) #\0)
219 (values nil end)
220 (values (parse-integer namestr :start (1+ i)
221 :end (1- end))
222 (1- i)))
223 (values :newest end))))
224 (unless (char<= #\0 char #\9)
225 ;; It's not a digit. Give up, and say the
226 ;; version is NIL.
227 ;;(format t "case 3 return: ~A ~A~%" nil end)
228 (return (values nil end))))))))
229 (any-version (namestr start end)
230 ;; process end of string looking for a version candidate.
231 (multiple-value-bind (version where)
232 (explicit-version namestr start end)
233 (cond ((not (eq version :newest))
234 (values version where))
235 ((and (not *ignore-wildcards*)
236 (>= (- end 2) start)
237 (char= (schar namestr (- end 1)) #\*)
238 (char= (schar namestr (- end 2)) #\.)
239 (find #\. namestr
240 :start (min (1+ start) (- end 2))
241 :end (- end 2)))
242 (values :wild (- end 2)))
243 (t (values version where)))))
244 (any-type (namestr start end)
245 ;; Process end of string looking for a type. A leading "."
246 ;; is part of the name.
247 (let ((where (position #\. namestr
248 :start (min (1+ start) end)
249 :end end :from-end t)))
250 (when where
251 (values where end))))
252 (any-name (namestr start end)
253 (declare (ignore namestr))
254 (values start end)))
255 (multiple-value-bind (version vstart)
256 (any-version namestr start end)
257 (multiple-value-bind (tstart tend)
258 (any-type namestr start vstart)
259 (multiple-value-bind (nstart nend)
260 (any-name namestr start (or tstart vstart))
261 (values
262 (maybe-make-pattern namestr nstart nend)
263 (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
264 version))))))
265
266 ;;; Take a string and return a list of cons cells that mark the char
267 ;;; separated subseq. The first value t if absolute directories location.
268 ;;;
269 (defun split-at-slashes (namestr start end)
270 (declare (type simple-base-string namestr)
271 (type index start end))
272 (let ((absolute (and (/= start end)
273 (char= (schar namestr start) #\/))))
274 (when absolute
275 (incf start))
276 ;; Next, split the remainder into slash separated chunks.
277 (collect ((pieces))
278 (loop
279 (let ((slash (position #\/ namestr :start start :end end)))
280 (pieces (cons start (or slash end)))
281 (unless slash
282 (return))
283 (setf start (1+ slash))))
284 (values absolute (pieces)))))
285
286 (defun maybe-extract-search-list (namestr start end)
287 (declare (type simple-base-string namestr)
288 (type index start end))
289 (let ((quoted nil))
290 (do ((index start (1+ index)))
291 ((= index end)
292 (values nil start))
293 (if quoted
294 (setf quoted nil)
295 (case (schar namestr index)
296 (#\\
297 (setf quoted t))
298 (#\:
299 (return (values (remove-backslashes namestr start index)
300 (1+ index)))))))))
301
302 (defun parse-unix-namestring (namestr start end)
303 (declare (type simple-base-string namestr)
304 (type index start end))
305 #+nil
306 (progn
307 (lisp::%primitive lisp::print "parse-unix-namestring")
308 (lisp::%primitive lisp::print namestr))
309 (multiple-value-bind
310 (absolute pieces)
311 (split-at-slashes namestr start end)
312 (let ((search-list
313 (if absolute
314 nil
315 (let ((first (car pieces)))
316 (multiple-value-bind
317 (search-list new-start)
318 (maybe-extract-search-list namestr
319 (car first) (cdr first))
320 #+nil
321 (progn
322 (lisp::%primitive lisp::print "maybe search-list:")
323 (lisp::%primitive lisp::print search-list))
324 (when search-list
325 ;; Lose if this search-list is already defined as
326 ;; a logical host. Since the syntax for
327 ;; search-lists and logical pathnames are the
328 ;; same, we can't allow the creation of one when
329 ;; the other is defined.
330 (when (find-logical-host search-list nil)
331 (error "~A already names a logical host" search-list))
332 (setf absolute t)
333 (setf (car first) new-start))
334 search-list)))))
335 (multiple-value-bind (name type version)
336 (let* ((tail (car (last pieces)))
337 (tail-start (car tail))
338 (tail-end (cdr tail)))
339 (unless (= tail-start tail-end)
340 (setf pieces (butlast pieces))
341 (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
342 ;; ".." is a directory. Add this piece to the
343 ;; list of pieces, and make the name/type/version
344 ;; nil.
345 (setf pieces (append pieces (list (cons tail-start tail-end))))
346 (values nil nil nil))
347 ((string= namestr "." :start1 tail-start :end1 tail-end)
348 ;; "." is a directory as well.
349 (setf pieces (append pieces (list (cons tail-start tail-end))))
350 (values nil nil nil))
351 ((not (find-if-not #'(lambda (c)
352 (char= c #\.))
353 namestr :start tail-start :end tail-end))
354 ;; Got a bunch of dots. Make it a file of the
355 ;; same name, and type the empty string.
356 (values (subseq namestr tail-start (1- tail-end)) "" nil))
357 (t
358 (extract-name-type-and-version namestr tail-start tail-end)))))
359 ;; PVE: Make sure there are no illegal characters in the name
360 ;; such as #\Null and #\/.
361 (when (and (stringp name)
362 (find-if #'(lambda (x)
363 (or (char= x #\Null) (char= x #\/)))
364 name))
365 #+nil
366 (progn
367 (lisp::%primitive lisp::print "Parse error null/slash")
368 (lisp::%primitive lisp::print name))
369 (error 'parse-error))
370 ;; Now we have everything we want. So return it.
371 (values nil ; no host for unix namestrings.
372 nil ; no devices for unix namestrings.
373 (collect ((dirs))
374 (when search-list
375 (dirs (intern-search-list search-list)))
376 (dolist (piece pieces)
377 (let ((piece-start (car piece))
378 (piece-end (cdr piece)))
379 (unless (= piece-start piece-end)
380 (cond ((string= namestr ".." :start1 piece-start
381 :end1 piece-end)
382 (dirs :up))
383 ((string= namestr "**" :start1 piece-start
384 :end1 piece-end)
385 (dirs :wild-inferiors))
386 (t
387 (dirs (maybe-make-pattern namestr
388 piece-start
389 piece-end)))))))
390 (cond (absolute
391 (cons :absolute (dirs)))
392 ((dirs)
393 ;; "." in a :relative directory is the same
394 ;; as if it weren't there, so remove them.
395 (cons :relative (delete "." (dirs) :test #'equal)))
396 (t
397 ;; If there is no directory and the name is
398 ;; "." and the type is NIL, we really got
399 ;; directory ".", so make it so.
400 (if (and (equal name ".")
401 (null type))
402 (list :relative)
403 nil))))
404 ;; A file with name "." and type NIL can't be the name
405 ;; of file on Unix because it's a directory. This was
406 ;; handled above, so we can just set the name to nil.
407 (if (and (equal name ".")
408 (null type))
409 nil
410 name)
411 type
412 version)))))
413
414 (defun unparse-unix-host (pathname)
415 (declare (type pathname pathname)
416 (ignore pathname))
417 ;; this host designator needs to be recognized as a physical host in
418 ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
419 ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
420 "")
421
422 (defun unparse-unix-piece (thing)
423 (etypecase thing
424 ((member :wild) "*")
425 ((member :unspecific)
426 ;; CLHS 19.2.2.2.3.1 says "That is, both nil and :unspecific
427 ;; cause the component not to appear in the namestring."
428 "")
429 (simple-string
430 (if *ignore-wildcards*
431 thing
432 (let* ((srclen (length thing))
433 (dstlen srclen))
434 (dotimes (i srclen)
435 (case (schar thing i)
436 ((#\* #\? #\[)
437 (incf dstlen))))
438 (let ((result (make-string dstlen))
439 (dst 0))
440 (dotimes (src srclen)
441 (let ((char (schar thing src)))
442 (case char
443 ((#\* #\? #\[)
444 (setf (schar result dst) #\\)
445 (incf dst)))
446 (setf (schar result dst) char)
447 (incf dst)))
448 result))))
449 (pattern
450 (collect ((strings))
451 (dolist (piece (pattern-pieces thing))
452 (etypecase piece
453 (simple-string
454 (strings piece))
455 (symbol
456 (ecase piece
457 (:multi-char-wild
458 (strings "*"))
459 (:single-char-wild
460 (strings "?"))))
461 (cons
462 (case (car piece)
463 (:character-set
464 (strings "[")
465 (strings (second piece))
466 (strings "]"))
467 (t
468 (error "Invalid pattern piece: ~S" piece))))))
469 (apply #'concatenate
470 'simple-string
471 (strings))))))
472
473 (defun unparse-unix-directory-list (directory)
474 (declare (type list directory))
475 (collect ((pieces))
476 (when directory
477 (ecase (pop directory)
478 (:absolute
479 (cond ((search-list-p (car directory))
480 (pieces (search-list-name (pop directory)))
481 (pieces ":"))
482 (t
483 (pieces "/"))))
484 (:relative
485 ;; Nothing special, except if we were given '(:relative).
486 (unless directory
487 (pieces "./"))
488 ))
489 (dolist (dir directory)
490 (typecase dir
491 ((member :up)
492 (pieces "../"))
493 ((member :back)
494 (error ":BACK cannot be represented in namestrings."))
495 ((member :wild-inferiors)
496 (pieces "**/"))
497 ((or simple-string pattern (eql :wild))
498 (pieces (unparse-unix-piece dir))
499 (pieces "/"))
500 (t
501 (error "Invalid directory component: ~S" dir)))))
502 (apply #'concatenate 'simple-string (pieces))))
503
504 (defun unparse-unix-directory (pathname)
505 (declare (type pathname pathname))
506 (unparse-unix-directory-list (%pathname-directory pathname)))
507
508 (defun unparse-unix-file (pathname)
509 (declare (type pathname pathname))
510 (collect ((strings))
511 (let* ((name (%pathname-name pathname))
512 (type (%pathname-type pathname))
513 (type-supplied (not (or (null type) (eq type :unspecific))))
514 (logical-p (logical-pathname-p pathname))
515 (version (%pathname-version pathname))
516 ;; Preserve version :newest for logical pathnames.
517 (version-supplied (not (or (null version)
518 (member version (if logical-p
519 '(:unspecific)
520 '(:newest
521 :unspecific)))))))
522 (when name
523 (when (stringp name)
524 (when (find #\/ name)
525 (error "Cannot specify a directory separator in a pathname name: ~S" name))
526 (when (and (not type-supplied)
527 (find #\. name :start 1))
528 ;; A single leading dot is ok.
529 (error "Cannot specify a dot in a pathname name without a pathname type: ~S" name))
530 (when (or (and (string= ".." name)
531 (not type-supplied))
532 (and (string= "." name)
533 (not type-supplied)))
534 ;; Can't have a name of ".." or "." without a type.
535 (error "Invalid value for a pathname name: ~S" name)))
536 (strings (unparse-unix-piece name)))
537 (when type-supplied
538 (unless name
539 (error "Cannot specify the type without a file: ~S" pathname))
540 (when (stringp type)
541 (when (find #\/ type)
542 (error "Cannot specify a directory separator in a pathname type: ~S" type))
543 (when (find #\. type)
544 (error "Cannot specify a dot in a pathname type: ~S" type)))
545 (strings ".")
546 (strings (unparse-unix-piece type)))
547 (when (and (not (member version '(nil :newest :unspecific)))
548 (not name))
549 ;; We don't want version without a name, because when we try
550 ;; to read #p".~*~" back, the name is "", not NIL.
551 (error "Cannot specify a version without a file: ~S" pathname))
552 (when version-supplied
553 (strings (if (eq version :wild)
554 (if logical-p ".*" ".~*~")
555 (format nil (if logical-p ".~A" ".~~~D~~")
556 version)))))
557 (and (strings) (apply #'concatenate 'simple-string (strings)))))
558
559 (defun unparse-unix-namestring (pathname)
560 (declare (type pathname pathname))
561 (concatenate 'simple-string
562 (unparse-unix-directory pathname)
563 (unparse-unix-file pathname)))
564
565 (defun unparse-unix-enough (pathname defaults)
566 (declare (type pathname pathname defaults))
567 (flet ((lose ()
568 (error "~S cannot be represented relative to ~S"
569 pathname defaults)))
570 ;; Only the first path in a search-list is considered.
571 (enumerate-search-list (pathname pathname)
572 (enumerate-search-list (defaults defaults)
573 (collect ((strings))
574 (let* ((pathname-directory (%pathname-directory pathname))
575 (defaults-directory (%pathname-directory defaults))
576 (prefix-len (length defaults-directory))
577 (result-dir
578 (cond ((null pathname-directory)
579 ;; No directory, so relative to default. But
580 ;; if we're relative to default, NIL is as
581 ;; good as '(:relative) and it results in a
582 ;; shorter namestring.
583 #+nil (list :relative)
584 nil)
585 ((and (>= prefix-len 1)
586 (>= (length pathname-directory) prefix-len)
587 (compare-component (subseq pathname-directory
588 0 prefix-len)
589 defaults-directory))
590 ;; Pathname starts with a prefix of default,
591 ;; which also means both are either :relative
592 ;; or :absolute directories. So just use a
593 ;; relative directory from then on out.
594 (let ((dir-tail (nthcdr prefix-len pathname-directory)))
595 ;; If both directories are identical, don't
596 ;; return just :relative. Returning NIL
597 ;; results in a shorter string.
598 (if dir-tail
599 (cons :relative dir-tail)
600 nil)))
601 ((and (eq (car pathname-directory) :relative)
602 (not (eq (car defaults-directory) :absolute)))
603 ;; Can't represent a relative directory
604 ;; relative to an absolute directory. But
605 ;; there's no problem if both are relative;
606 ;; we just return our path.
607 pathname-directory)
608 ((eq (car pathname-directory) :absolute)
609 ;; We are an absolute pathname, so we can just use it.
610 pathname-directory)
611 (t
612 ;; We are a relative directory. So we lose.
613 (lose)))))
614 (strings (unparse-unix-directory-list result-dir)))
615 (let* ((pathname-version (%pathname-version pathname))
616 (version-needed (and pathname-version
617 (not (eq pathname-version :newest))))
618 (pathname-type (%pathname-type pathname))
619 (type-needed (or version-needed
620 (and pathname-type
621 (not (eq pathname-type :unspecific)))))
622 (pathname-name (%pathname-name pathname))
623 (name-needed (or type-needed
624 (and pathname-name
625 (not (compare-component pathname-name
626 (%pathname-name
627 defaults)))))))
628 (when name-needed
629 (unless pathname-name (lose))
630 (strings (unparse-unix-piece pathname-name)))
631 (when type-needed
632 (when (or (null pathname-type) (eq pathname-type :unspecific))
633 (lose))
634 (strings ".")
635 (strings (unparse-unix-piece pathname-type)))
636 (when version-needed
637 (typecase pathname-version
638 ((member :wild)
639 (strings ".~*~"))
640 (integer
641 (strings (format nil ".~~~D~~" pathname-version)))
642 (t
643 (lose)))))
644 (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings))))))))
645
646
647 (defstruct (unix-host
648 (:include host
649 (:parse #'parse-unix-namestring)
650 (:unparse #'unparse-unix-namestring)
651 (:unparse-host #'unparse-unix-host)
652 (:unparse-directory #'unparse-unix-directory)
653 (:unparse-file #'unparse-unix-file)
654 (:unparse-enough #'unparse-unix-enough)
655 (:customary-case :lower))
656 (:make-load-form-fun make-unix-host-load-form))
657 )
658
659 (defvar *unix-host* (make-unix-host))
660
661 (defun make-unix-host-load-form (host)
662 (declare (ignore host))
663 '*unix-host*)
664
665
666 ;;;; Wildcard matching stuff.
667
668 (defmacro enumerate-matches ((var pathname &optional result
669 &key (verify-existance t) (follow-links t))
670 &body body)
671 (let ((body-name (gensym)))
672 `(block nil
673 (flet ((,body-name (,var)
674 ,@body))
675 (%enumerate-matches (pathname ,pathname)
676 ,verify-existance ,follow-links
677 #',body-name)
678 ,result))))
679
680 (defun %enumerate-matches (pathname verify-existance follow-links function)
681 (when (pathname-type pathname)
682 (unless (pathname-name pathname)
683 (error "Cannot supply a type without a name:~% ~S" pathname)))
684 (let ((directory (pathname-directory pathname)))
685 (if directory
686 (ecase (car directory)
687 (:absolute
688 (%enumerate-directories "/" (cdr directory) pathname
689 verify-existance follow-links
690 nil function))
691 (:relative
692 (%enumerate-directories "" (cdr directory) pathname
693 verify-existance follow-links
694 nil function)))
695 (%enumerate-files "" pathname verify-existance function))))
696
697 ;;; %enumerate-directories -- Internal
698 ;;;
699 ;;; The directory node and device numbers are maintained for the current path
700 ;;; during the search for the detection of path loops upon :wild-inferiors.
701 ;;;
702 (defun %enumerate-directories (head tail pathname verify-existance
703 follow-links nodes function)
704 (declare (simple-string head))
705 (macrolet ((unix-xstat (name)
706 `(if follow-links
707 (unix:unix-stat ,name)
708 (unix:unix-lstat ,name)))
709 (with-directory-node-noted ((head) &body body)
710 `(multiple-value-bind (res dev ino mode)
711 (unix-xstat ,head)
712 (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
713 (let ((nodes (cons (cons dev ino) nodes)))
714 ,@body))))
715 (do-directory-entries ((name directory) &body body)
716 `(let ((dir (unix:open-dir ,directory)))
717 (when dir
718 (unwind-protect
719 (loop
720 (let ((,name (unix:read-dir dir)))
721 (cond ((null ,name)
722 (return))
723 ((string= ,name "."))
724 ((string= ,name ".."))
725 (t
726 ,@body))))
727 (unix:close-dir dir))))))
728 (if tail
729 (let ((piece (car tail)))
730 (etypecase piece
731 (simple-string
732 (let ((head (concatenate 'string head piece)))
733 (with-directory-node-noted (head)
734 (%enumerate-directories (concatenate 'string head "/")
735 (cdr tail) pathname
736 verify-existance follow-links
737 nodes function))))
738 ((member :wild-inferiors)
739 (%enumerate-directories head (rest tail) pathname
740 verify-existance follow-links
741 nodes function)
742 (do-directory-entries (name head)
743 (let ((subdir (concatenate 'string head name)))
744 (multiple-value-bind (res dev ino mode)
745 (unix-xstat subdir)
746 (declare (type (or fixnum null) mode))
747 (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
748 (unless (dolist (dir nodes nil)
749 (when (and (eql (car dir) dev)
750 (eql (cdr dir) ino))
751 (return t)))
752 (let ((nodes (cons (cons dev ino) nodes))
753 (subdir (concatenate 'string subdir "/")))
754 (%enumerate-directories subdir tail pathname
755 verify-existance follow-links
756 nodes function))))))))
757 ((or pattern (member :wild))
758 (do-directory-entries (name head)
759 (when (or (eq piece :wild) (pattern-matches piece name))
760 (let ((subdir (concatenate 'string head name)))
761 (multiple-value-bind (res dev ino mode)
762 (unix-xstat subdir)
763 (declare (type (or fixnum null) mode))
764 (when (and res
765 (eql (logand mode unix:s-ifmt) unix:s-ifdir))
766 (let ((nodes (cons (cons dev ino) nodes))
767 (subdir (concatenate 'string subdir "/")))
768 (%enumerate-directories subdir (rest tail) pathname
769 verify-existance follow-links
770 nodes function))))))))
771 ((member :up)
772 (let ((head (concatenate 'string head "..")))
773 (with-directory-node-noted (head)
774 (%enumerate-directories (concatenate 'string head "/")
775 (rest tail) pathname
776 verify-existance follow-links
777 nodes function))))))
778 (%enumerate-files head pathname verify-existance function))))
779
780 (defun %enumerate-files (directory pathname verify-existance function)
781 (declare (simple-string directory))
782 (let ((name (%pathname-name pathname))
783 (type (%pathname-type pathname))
784 (version (%pathname-version pathname)))
785 (cond ((member name '(nil :unspecific))
786 (when (or (not verify-existance)
787 (unix:unix-file-kind directory))
788 (funcall function directory)))
789 ((or (pattern-p name)
790 (pattern-p type)
791 (eq name :wild)
792 (eq type :wild)
793 (eq version :wild))
794 (let ((dir (unix:open-dir directory)))
795 (when dir
796 (unwind-protect
797 (loop
798 (let ((file (unix:read-dir dir)))
799 (if file
800 (unless (or (string= file ".")
801 (string= file ".."))
802 (multiple-value-bind
803 (file-name file-type file-version)
804 (let ((*ignore-wildcards* t))
805 (extract-name-type-and-version
806 file 0 (length file)))
807 ;; Match also happens if the file has
808 ;; no explicit version and we're asking
809 ;; for version :NEWEST, since that's
810 ;; what no version means.
811 (when (and (components-match file-name name)
812 (components-match file-type type)
813 (or (components-match file-version
814 version)
815 (and (eq file-version nil)
816 (eq version :newest))))
817 (funcall function
818 (concatenate 'string
819 directory
820 file)))))
821 (return))))
822 (unix:close-dir dir)))))
823 (t
824 (let ((file (concatenate 'string directory name)))
825 (unless (or (null type) (eq type :unspecific))
826 (setf file (concatenate 'string file "." type)))
827 (unless (member version '(nil :newest :wild :unspecific))
828 (setf file (concatenate 'string file ".~"
829 (quick-integer-to-string version)
830 "~")))
831 (when (or (not verify-existance)
832 (unix:unix-file-kind file t))
833 (funcall function file)))))))
834
835 (defun quick-integer-to-string (n)
836 (declare (type integer n))
837 (cond ((not (fixnump n))
838 (write-to-string n :base 10 :radix nil))
839 ((zerop n) "0")
840 ((eql n 1) "1")
841 ((minusp n)
842 (concatenate 'simple-string "-"
843 (the simple-string (quick-integer-to-string (- n)))))
844 (t
845 (do* ((len (1+ (truncate (integer-length n) 3)))
846 (res (make-string len))
847 (i (1- len) (1- i))
848 (q n)
849 (r 0))
850 ((zerop q)
851 (incf i)
852 (replace res res :start2 i :end2 len)
853 (shrink-vector res (- len i)))
854 (declare (simple-string res)
855 (fixnum len i r q))
856 (multiple-value-setq (q r) (truncate q 10))
857 (setf (schar res i) (schar "0123456789" r))))))
858
859
860 ;;;; UNIX-NAMESTRING -- public
861 ;;;
862 (defun unix-namestring (pathname &optional (for-input t) executable-only)
863 "Convert PATHNAME into a string that can be used with UNIX system calls.
864 Search-lists and wild-cards are expanded. If optional argument
865 FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned.
866 If optional argument EXECUTABLE-ONLY is true, NIL is returned
867 unless an executable version of PATHNAME exists."
868 ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
869 ;; pathnames too.
870 (let ((path (let ((lpn (pathname pathname)))
871 (if (logical-pathname-p lpn)
872 (namestring (translate-logical-pathname lpn))
873 pathname))))
874 (enumerate-search-list
875 (pathname path)
876 (collect ((names))
877 (enumerate-matches (name pathname nil :verify-existance for-input
878 :follow-links t)
879 (when (or (not executable-only)
880 (and (eq (unix:unix-file-kind name) :file)
881 (unix:unix-access name unix:x_ok)))
882 (names name)))
883 (let ((names (names)))
884 (when names
885 (when (cdr names)
886 (error 'simple-file-error
887 :format-control "~S is ambiguous:~{~% ~A~}"
888 :format-arguments (list pathname names)))
889 (return (car names))))))))
890
891
892 ;;;; TRUENAME and PROBE-FILE.
893
894 ;;; Truename -- Public
895 ;;;
896 ;;; Another silly file function trivially different from another function.
897 ;;;
898 (defun truename (pathname)
899 "Return the pathname for the actual file described by the pathname
900 An error of type file-error is signalled if no such file exists,
901 or the pathname is wild."
902 (if (wild-pathname-p pathname)
903 (error 'simple-file-error
904 :format-control "Bad place for a wild pathname."
905 :pathname pathname)
906 (let ((result (probe-file pathname)))
907 (unless result
908 (error 'simple-file-error
909 :pathname pathname
910 :format-control "The file ~S does not exist."
911 :format-arguments (list (namestring pathname))))
912 result)))
913
914 ;;; Probe-File -- Public
915 ;;;
916 ;;; If PATHNAME exists, return its truename, otherwise NIL.
917 ;;;
918 (defun probe-file (pathname)
919 "Return a pathname which is the truename of the file if it exists, NIL
920 otherwise. An error of type file-error is signalled if pathname is wild."
921 (if (wild-pathname-p pathname)
922 (error 'simple-file-error
923 :pathname pathname
924 :format-control "Bad place for a wild pathname.")
925 (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
926 (when (and namestring (unix:unix-file-kind namestring))
927 (let ((truename (unix:unix-resolve-links
928 (unix:unix-maybe-prepend-current-directory
929 namestring))))
930 (when truename
931 (let ((*ignore-wildcards* t))
932 (pathname (unix:unix-simplify-pathname truename)))))))))
933
934
935 ;;;; Other random operations.
936
937 ;;; Rename-File -- Public
938 ;;;
939 (defun rename-file (file new-name)
940 "Rename File to have the specified New-Name. If file is a stream open to a
941 file, then the associated file is renamed."
942 (let* ((original (truename file))
943 (original-namestring (unix-namestring original t))
944 (new-name (merge-pathnames new-name original))
945 (new-namestring (unix-namestring new-name nil)))
946 (unless new-namestring
947 (error 'simple-file-error
948 :pathname new-name
949 :format-control "~S can't be created."
950 :format-arguments (list new-name)))
951 (multiple-value-bind (res error)
952 (unix:unix-rename original-namestring
953 new-namestring)
954 (unless res
955 (error 'simple-file-error
956 :pathname new-name
957 :format-control "Failed to rename ~A to ~A: ~A"
958 :format-arguments (list original new-name
959 (unix:get-unix-error-msg error))))
960 (when (streamp file)
961 (file-name file new-namestring))
962 (values new-name original (truename new-name)))))
963
964 ;;; Delete-File -- Public
965 ;;;
966 ;;; Delete the file, Man.
967 ;;;
968 (defun delete-file (file)
969 "Delete the specified file."
970 (let ((namestring (unix-namestring file t)))
971 (when (streamp file)
972 ;; Close the file, but don't try to revert or anything. We want
973 ;; to delete it, man!
974 (close file))
975 (unless namestring
976 (error 'simple-file-error
977 :pathname file
978 :format-control "~S doesn't exist."
979 :format-arguments (list file)))
980
981 (multiple-value-bind (res err) (unix:unix-unlink namestring)
982 (unless res
983 (error 'simple-file-error
984 :pathname namestring
985 :format-control "Could not delete ~A: ~A."
986 :format-arguments (list namestring
987 (unix:get-unix-error-msg err))))))
988 t)
989
990 ;;; Purge-Backup-Files -- Public
991 ;;;
992 ;;; Purge old file versions
993 ;;;
994 (defun purge-backup-files (pathname &optional (keep 0))
995 "Delete old versions of files matching the given Pathname,
996 optionally keeping some of the most recent old versions."
997 (declare (type (or pathname string stream) pathname)
998 (type (integer 0 *) keep))
999 (let ((hash (make-hash-table :test 'equal)))
1000 (enumerate-search-list
1001 (path (make-pathname :version :wild :defaults pathname))
1002 (clrhash hash)
1003 (enumerate-matches (name path nil :follow-links nil)
1004 (let ((dot (position #\. name :from-end t))
1005 (len (length name)))
1006 (when (and dot
1007 (> len (+ dot 3))
1008 (char= (char name (1+ dot)) #\~)
1009 (char= (char name (1- len)) #\~)
1010 (eq (unix:unix-file-kind name) :file))
1011 (multiple-value-bind (version next)
1012 (parse-integer name :start (+ dot 2) :end (1- len)
1013 :junk-allowed t)
1014 (when (and version (= next (1- len)))
1015 (push (cons version name)
1016 (gethash (subseq name 0 dot) hash '())))))))
1017 (maphash (lambda (key value)
1018 (declare (ignore key))
1019 (mapc #'unix:unix-unlink
1020 (mapcar #'cdr (nthcdr keep
1021 (sort value #'> :key #'car)))))
1022 hash))))
1023
1024
1025 ;;; User-Homedir-Pathname -- Public
1026 ;;;
1027 ;;; Return Home:, which is set up for us at initialization time.
1028 ;;;
1029 (defun user-homedir-pathname (&optional host)
1030 "Returns the home directory of the logged in user as a pathname.
1031 This is obtained from the logical name \"home:\"."
1032 (declare (ignore host))
1033 #p"home:")
1034
1035 ;;; File-Write-Date -- Public
1036 ;;;
1037 (defun file-write-date (file)
1038 "Return file's creation date, or NIL if it doesn't exist.
1039 An error of type file-error is signalled if file is a wild pathname"
1040 (if (wild-pathname-p file)
1041 (error 'simple-file-error
1042 :pathname file
1043 :format-control "Bad place for a wild pathname.")
1044 (let ((name (unix-namestring file t)))
1045 (when name
1046 (multiple-value-bind
1047 (res dev ino mode nlink uid gid rdev size atime mtime)
1048 (unix:unix-stat name)
1049 (declare (ignore dev ino mode nlink uid gid rdev size atime))
1050 (when res
1051 (+ unix-to-universal-time mtime)))))))
1052
1053 ;;; File-Author -- Public
1054 ;;;
1055 (defun file-author (file)
1056 "Returns the file author as a string, or nil if the author cannot be
1057 determined. Signals an error of type file-error if file doesn't exist,
1058 or file is a wild pathname."
1059 (if (wild-pathname-p file)
1060 (error 'simple-file-error
1061 :pathname file
1062 :format-control "Bad place for a wild pathname.")
1063 (let ((name (unix-namestring (pathname file) t)))
1064 (unless name
1065 (error 'simple-file-error
1066 :pathname file
1067 :format-control "~S doesn't exist."
1068 :format-arguments (list file)))
1069 (multiple-value-bind (winp dev ino mode nlink uid)
1070 (unix:unix-stat name)
1071 (declare (ignore dev ino mode nlink))
1072 (when winp
1073 (let ((user-info (unix:unix-getpwuid uid)))
1074 (when user-info
1075 (unix:user-info-name user-info))))))))
1076
1077
1078 ;;;; DIRECTORY.
1079
1080 ;;; DIRECTORY -- public.
1081 ;;;
1082 (defun directory (pathname &key (all t) (check-for-subdirs t)
1083 (truenamep t) (follow-links t))
1084 "Returns a list of pathnames, one for each file that matches the given
1085 pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This
1086 never includes Unix dot and dot-dot in the result. If :TRUENAMEP is NIL,
1087 then symbolic links in the result are not expanded, which is not the
1088 default because TRUENAME does follow links and the result pathnames are
1089 defined to be the TRUENAME of the pathname (the truename of a link may well
1090 be in another directory). If FOLLOW-LINKS is NIL then symbolic links are
1091 not followed."
1092 (let ((results nil))
1093 (enumerate-search-list
1094 (pathname (merge-pathnames pathname
1095 (make-pathname :name :wild
1096 :type :wild
1097 :version :wild
1098 :defaults *default-pathname-defaults*)
1099 :wild))
1100 (enumerate-matches (name pathname nil :follow-links follow-links)
1101 (when (or all
1102 (let ((slash (position #\/ name :from-end t)))
1103 (or (null slash)
1104 (= (1+ slash) (length name))
1105 (char/= (schar name (1+ slash)) #\.))))
1106 (push name results))))
1107 (let ((*ignore-wildcards* t))
1108 (mapcar #'(lambda (name)
1109 (let ((name (if (and check-for-subdirs
1110 (eq (unix:unix-file-kind name)
1111 :directory))
1112 (concatenate 'string name "/")
1113 name)))
1114 (if truenamep (truename name) (pathname name))))
1115 (sort (delete-duplicates results :test #'string=) #'string<)))))
1116
1117
1118 ;;;; Printing directories.
1119
1120 ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
1121 ;;;
1122 (defun print-directory (pathname &optional stream &key all verbose return-list)
1123 "Like Directory, but prints a terse, multi-column directory listing
1124 instead of returning a list of pathnames. When :all is supplied and
1125 non-nil, then Unix dot files are included too (as ls -a). When :verbose
1126 is supplied and non-nil, then a long listing of miscellaneous
1127 information is output one file per line."
1128 (let ((*standard-output* (out-synonym-of stream))
1129 (pathname pathname))
1130 (if verbose
1131 (print-directory-verbose pathname all return-list)
1132 (print-directory-formatted pathname all return-list))))
1133
1134 (defun print-directory-verbose (pathname all return-list)
1135 (let ((contents (directory pathname :all all :check-for-subdirs nil
1136 :truenamep nil))
1137 (result nil))
1138 (format t "Directory of ~A:~%" (namestring pathname))
1139 (dolist (file contents)
1140 (let* ((namestring (unix-namestring file))
1141 (tail (subseq namestring
1142 (1+ (or (position #\/ namestring
1143 :from-end t
1144 :test #'char=)
1145 -1)))))
1146 (multiple-value-bind
1147 (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
1148 (unix:unix-stat namestring)
1149 (declare (ignore ino gid rdev atime)
1150 (fixnum uid mode))
1151 (cond (reslt
1152 ;;
1153 ;; Print characters for file modes.
1154 (macrolet ((frob (bit name &optional sbit sname negate)
1155 `(if ,(if negate
1156 `(not (logbitp ,bit mode))
1157 `(logbitp ,bit mode))
1158 ,(if sbit
1159 `(if (logbitp ,sbit mode)
1160 (write-char ,sname)
1161 (write-char ,name))
1162 `(write-char ,name))
1163 (write-char #\-))))
1164 (frob 15 #\d nil nil t)
1165 (frob 8 #\r)
1166 (frob 7 #\w)
1167 (frob 6 #\x 11 #\s)
1168 (frob 5 #\r)
1169 (frob 4 #\w)
1170 (frob 3 #\x 10 #\s)
1171 (frob 2 #\r)
1172 (frob 1 #\w)
1173 (frob 0 #\x))
1174 ;;
1175 ;; Print the rest.
1176 (multiple-value-bind (sec min hour date month year)
1177 (get-decoded-time)
1178 (declare (ignore sec min hour date month))
1179 (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"
1180 nlink
1181 (let ((user-info (unix:unix-getpwuid uid)))
1182 (if user-info (unix:user-info-name user-info) uid))
1183 size
1184 (decode-universal-time-for-files mtime year)
1185 tail
1186 (= (logand mode unix:s-ifmt) unix:s-ifdir))))
1187 (t (format t "Couldn't stat ~A -- ~A.~%"
1188 tail
1189 (unix:get-unix-error-msg dev-or-err))))
1190 (when return-list
1191 (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
1192 (pathname (concatenate 'string namestring "/"))
1193 file)
1194 result)))))
1195 (nreverse result)))
1196
1197 (defun decode-universal-time-for-files (time current-year)
1198 (multiple-value-bind (sec min hour day month year)
1199 (decode-universal-time (+ time unix-to-universal-time))
1200 (declare (ignore sec))
1201 (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
1202 (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
1203 "Sep" "Oct" "Nov" "Dec")
1204 (1- month))
1205 day (= current-year year) year hour min)))
1206
1207 (defun print-directory-formatted (pathname all return-list)
1208 (let ((width (or (line-length *standard-output*) 80))
1209 (names ())
1210 (cnt 0)
1211 (max-len 0)
1212 (result (directory pathname :all all :truenamep nil)))
1213 (declare (list names) (fixnum max-len cnt))
1214 ;;
1215 ;; Get the data.
1216 (dolist (file result)
1217 (let* ((name (unix-namestring file))
1218 (length (length name))
1219 (end (if (and (plusp length)
1220 (char= (schar name (1- length)) #\/))
1221 (1- length)
1222 length))
1223 (slash-name (subseq name
1224 (1+ (or (position #\/ name
1225 :from-end t
1226 :end end
1227 :test #'char=)
1228 -1))))
1229 (len (length slash-name)))
1230 (declare (simple-string slash-name)
1231 (fixnum len))
1232 (if (> len max-len) (setq max-len len))
1233 (incf cnt)
1234 (push slash-name names)))
1235 (setq names (nreverse names))
1236 ;;
1237 ;; Do the output.
1238 (let* ((col-width (1+ max-len))
1239 (cols (max (truncate width col-width) 1))
1240 (lines (ceiling cnt cols)))
1241 (declare (fixnum cols lines))
1242 (format t "Directory of ~A:~%" (namestring pathname))
1243 (dotimes (i lines)
1244 (declare (fixnum i))
1245 (dotimes (j cols)
1246 (declare (fixnum j))
1247 (let ((name (nth (+ i (the fixnum (* j lines))) names)))
1248 (when name
1249 (write-string name)
1250 (unless (eql j (1- cols))
1251 (dotimes (i (- col-width (length (the simple-string name))))
1252 (write-char #\space))))))
1253 (terpri)))
1254 (when return-list
1255 result)))
1256
1257
1258 ;;;; File completion.
1259
1260 ;;; COMPLETE-FILE -- Public
1261 ;;;
1262 (defun complete-file (pathname &key (defaults *default-pathname-defaults*)
1263 ignore-types)
1264 (let ((files (directory (complete-file-directory-arg pathname defaults)
1265 :check-for-subdirs nil
1266 :truenamep nil)))
1267 (cond ((null files)
1268 (values nil nil))
1269 ((null (cdr files))
1270 (values (merge-pathnames (file-namestring (car files))
1271 pathname)
1272 t))
1273 (t
1274 (let ((good-files
1275 (delete-if #'(lambda (pathname)
1276 (and (simple-string-p
1277 (pathname-type pathname))
1278 (member (pathname-type pathname)
1279 ignore-types
1280 :test #'string=)))
1281 files)))
1282 (cond ((null good-files))
1283 ((null (cdr good-files))
1284 (return-from complete-file
1285 (values (merge-pathnames (file-namestring
1286 (car good-files))
1287 pathname)
1288 t)))
1289 (t
1290 (setf files good-files)))
1291 (let ((common (file-namestring (car files))))
1292 (dolist (file (cdr files))
1293 (let ((name (file-namestring file)))
1294 (dotimes (i (min (length common) (length name))
1295 (when (< (length name) (length common))
1296 (setf common name)))
1297 (unless (char= (schar common i) (schar name i))
1298 (setf common (subseq common 0 i))
1299 (return)))))
1300 (values (merge-pathnames common pathname)
1301 nil)))))))
1302
1303 ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
1304 ;;;
1305 (defun complete-file-directory-arg (pathname defaults)
1306 (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
1307 (type (pathname-type pathname)))
1308 (flet ((append-multi-char-wild (thing)
1309 (etypecase thing
1310 (null :wild)
1311 (pattern
1312 (make-pattern (append (pattern-pieces thing)
1313 (list :multi-char-wild))))
1314 (simple-string
1315 (make-pattern (list thing :multi-char-wild))))))
1316 (if (or (null type) (eq type :unspecific))
1317 ;; There is no type.
1318 (make-pathname :defaults pathname
1319 :name (append-multi-char-wild (pathname-name pathname))
1320 :type :wild)
1321 ;; There already is a type, so just extend it.
1322 (make-pathname :defaults pathname
1323 :name (pathname-name pathname)
1324 :type (append-multi-char-wild (pathname-type pathname)))))))
1325
1326 ;;; Ambiguous-Files -- Public
1327 ;;;
1328 (defun ambiguous-files (pathname
1329 &optional (defaults *default-pathname-defaults*))
1330 "Return a list of all files which are possible completions of Pathname.
1331 We look in the directory specified by Defaults as well as looking down
1332 the search list."
1333 (directory (complete-file-directory-arg pathname defaults)
1334 :truenamep nil
1335 :check-for-subdirs nil))
1336
1337
1338
1339 ;;; File-writable -- exported from extensions.
1340 ;;;
1341 ;;; Determines whether the single argument (which should be a pathname)
1342 ;;; can be written by the current task.
1343 ;;;
1344 (defun file-writable (name)
1345 "File-writable accepts a pathname and returns T if the current
1346 process can write it, and NIL otherwise."
1347 (let ((name (unix-namestring name nil)))
1348 (cond ((null name)
1349 nil)
1350 ((unix:unix-file-kind name)
1351 (values (unix:unix-access name unix:w_ok)))
1352 (t
1353 (values
1354 (unix:unix-access (subseq name
1355 0
1356 (or (position #\/ name :from-end t)
1357 0))
1358 (logior unix:w_ok unix:x_ok)))))))
1359
1360
1361 ;;; Pathname-Order -- Internal
1362 ;;;
1363 ;;; Predicate to order pathnames by. Goes by name.
1364 ;;;
1365 (defun pathname-order (x y)
1366 (let ((xn (%pathname-name x))
1367 (yn (%pathname-name y)))
1368 (if (and xn yn)
1369 (let ((res (string-lessp xn yn)))
1370 (cond ((not res) nil)
1371 ((= res (length (the simple-string xn))) t)
1372 ((= res (length (the simple-string yn))) nil)
1373 (t t)))
1374 xn)))
1375
1376
1377 ;;; Default-Directory -- Public
1378 ;;;
1379 (defun default-directory ()
1380 "Returns the pathname for the default directory. This is the place where
1381 a file will be written if no directory is specified. This may be changed
1382 with setf."
1383 (multiple-value-bind (gr dir-or-error)
1384 (unix:unix-current-directory)
1385 (if gr
1386 (let ((*ignore-wildcards* t))
1387 (values
1388 (parse-namestring (concatenate 'simple-string dir-or-error "/")
1389 *unix-host*)))
1390 (error dir-or-error))))
1391 ;;;
1392 ;;; XXXX This code was modified by me (fmg) to avoid calling
1393 ;;; concatenate. The reason for this is that there have been
1394 ;;; intermittent instabilities (segv on startup) when the function
1395 ;;; environment-init (in save.lisp) is called. Apparently the type
1396 ;;; system is not completely sorted out at the time this function is
1397 ;;; first called. As a result, strange, not completely reproducable
1398 ;;; things happen, related to something in the state of the
1399 ;;; environment (e.g. the paths or the user environment variables or
1400 ;;; something). These errors occur in the course of calling
1401 ;;; default-directory and the backtrace indicates they occur in the
1402 ;;; context of the type system. Since I haven't been able to figure
1403 ;;; out why they happen, I decided to punt.
1404 ;;;
1405 ;;; Hopefully someone will really fix the problem someday.
1406 ;;;
1407 ;;; Seems like maybe it's fixed by changes made by Ray Toy to avoid heap corruption.
1408 #- (and)
1409 (defun default-directory ()
1410 "Returns the pathname for the default directory. This is the place where
1411 a file will be written if no directory is specified. This may be changed
1412 with setf."
1413 (multiple-value-bind (gr dir-or-error)
1414 (unix:unix-current-directory)
1415 (if gr
1416 (let ((*ignore-wildcards* t)
1417 (string (make-string (1+ (length dir-or-error)) :initial-element #\/)))
1418 (values
1419 (parse-namestring (replace string dir-or-error) *unix-host*)))
1420 (error dir-or-error))))
1421
1422
1423
1424
1425 ;;; %Set-Default-Directory -- Internal
1426 ;;;
1427 (defun %set-default-directory (new-val)
1428 (let ((namestring (unix-namestring new-val t)))
1429 (unless namestring
1430 (error 'simple-file-error
1431 :format-control "~S doesn't exist."
1432 :format-arguments (list new-val)))
1433 (multiple-value-bind (gr error)
1434 (unix:unix-chdir namestring)
1435 (if gr
1436 (setf (search-list "default:") (default-directory))
1437 (error (unix:get-unix-error-msg error))))
1438 new-val))
1439 ;;;
1440 (defsetf default-directory %set-default-directory)
1441
1442 (defun filesys-init ()
1443 ;; Use :unspecific so we don't create file versions whenever merging
1444 ;; happens. If the user wants that, let him change
1445 ;; *default-pathname-defaults* appropriately.
1446 (setf *default-pathname-defaults*
1447 (%make-pathname *unix-host* nil nil nil nil :unspecific))
1448 (setf (search-list "default:") (default-directory))
1449 nil)
1450
1451 ;;; Ensure-Directories-Exist -- Public
1452 ;;;
1453 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1454 "Tests whether the directories containing the specified file
1455 actually exist, and attempts to create them if they do not.
1456 Portable programs should avoid using the :MODE keyword argument."
1457 (let* ((pathname (pathname pathspec))
1458 (pathname (if (logical-pathname-p pathname)
1459 (translate-logical-pathname pathname)
1460 pathname))
1461 (created-p nil))
1462 (when (wild-pathname-p pathname)
1463 (error 'simple-file-error
1464 :format-control "Bad place for a wild pathname."
1465 :pathname pathspec))
1466 (enumerate-search-list (pathname pathname)
1467 (let ((dir (pathname-directory pathname)))
1468 (loop for i from 1 upto (length dir)
1469 do (let ((newpath (make-pathname
1470 :host (pathname-host pathname)
1471 :device (pathname-device pathname)
1472 :directory (subseq dir 0 i))))
1473 (tagbody
1474 retry
1475 (restart-case
1476 (unless (probe-file newpath)
1477 (let ((namestring (namestring newpath)))
1478 (when verbose
1479 (format *standard-output* "~&Creating directory: ~A~%"
1480 namestring))
1481 (unix:unix-mkdir namestring mode)
1482 (unless (probe-file namestring)
1483 (error 'simple-file-error
1484 :pathname pathspec
1485 :format-control "Can't create directory ~A."
1486 :format-arguments (list namestring)))
1487 (setf created-p t)))
1488 (retry () :report "Try to create the directory again"
1489 (go retry))))))
1490 ;; Only the first path in a search-list is considered.
1491 (return (values pathname created-p))))))

  ViewVC Help
Powered by ViewVC 1.1.5