source: trunk/source/level-1/l1-files.lisp @ 15776

Last change on this file since 15776 was 15776, checked in by gz, 8 years ago

replaced calls to native-translated-namestring with (new) defaulted-native-namestring where seemed appropriate. Fixes ticket:1070

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 60.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001-2009 Clozure Associates
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;; L1-files.lisp - Object oriented file stuff
19
20(in-package "CCL")
21
22(defconstant $paramErr -50)   ; put this with the rest when we find the rest
23
24(defconstant pathname-case-type '(member :common :local :studly))
25(defconstant pathname-arg-type '(or string pathname stream))
26
27(defmacro signal-file-error (err-num &optional pathname &rest args)
28  `(%signal-file-error ,err-num
29    ,@(if pathname (list pathname))
30              ,@(if args args)))
31
32(defun %signal-file-error (err-num &optional pathname args)
33  (declare (fixnum err-num))
34  (let* ((err-code (logior (ash 2 16) (the fixnum (logand #xffff (the fixnum err-num))))))
35    (funcall (if (< err-num 0) '%errno-disp '%err-disp)
36             err-code
37             pathname
38             args)))
39
40
41(defvar %logical-host-translations% '())
42(defvar *load-pathname* nil
43  "the defaulted pathname that LOAD is currently loading")
44(defvar *load-truename* nil
45  "the TRUENAME of the file that LOAD is currently loading")
46
47
48(defparameter *default-pathname-defaults*
49  (let* ((hide-from-compile-file (%cons-pathname nil nil nil)))
50    hide-from-compile-file))
51
52;Right now, the only way it's used is that an explicit ";" expands into it.
53;Used to merge with it before going to ROM.  Might be worth to bring that back,
54;it doesn't hurt anything if you don't set it.
55;(defparameter *working-directory* (%cons-pathname nil nil nil))
56
57;These come in useful...  We should use them consistently and then document them,
58;thereby earning the eternal gratitude of any users who find themselves with a
59;ton of "foo.CL" files...
60(defparameter *.fasl-pathname*
61  (%cons-pathname nil nil
62                  #.(pathname-type
63                     (backend-target-fasl-pathname *target-backend*))))
64
65(defparameter *.lisp-pathname* (%cons-pathname nil nil "lisp"))
66
67(defun if-exists (if-exists filename &optional (prompt "Create ..."))
68  (case if-exists
69    (:error (signal-file-error (- #$EEXIST) filename))
70    ((:dialog) (overwrite-dialog filename prompt))
71    ((nil) nil)
72    ((:ignored :overwrite :append :supersede :rename-and-delete :new-version :rename) filename)
73    (t (report-bad-arg if-exists '(member :error :dialog nil :ignored :overwrite :append :supersede :rename-and-delete)))))
74
75(defun if-does-not-exist (if-does-not-exist filename)
76  (case if-does-not-exist 
77    (:error (signal-file-error (- #$ENOENT) filename)) ; (%err-disp $err-no-file filename))
78    (:create filename)
79    ((nil) (return-from if-does-not-exist nil))
80    (t (report-bad-arg if-does-not-exist '(member :error :create nil)))))
81
82
83(defun defaulted-native-namestring (path)
84  (native-translated-namestring (merge-pathnames path)))
85
86(defun native-translated-namestring (path)
87  (let ((name (let ((*default-pathname-defaults* #P""))
88                (translated-namestring path))))
89    ;; Check that no quoted /'s
90    (when (%path-mem-last-quoted "/" name)
91      (signal-file-error $xbadfilenamechar name #\/))
92    ;; Check that no unquoted wildcards.
93    (when (%path-mem-last "*" name)
94      (signal-file-error $xillwild name))
95    (namestring-unquote name)))
96
97(defun native-untranslated-namestring (path)
98  (let ((name (namestring (translate-logical-pathname path))))
99    ;; Check that no quoted /'s
100    (when (%path-mem-last-quoted "/" name)
101      (signal-file-error $xbadfilenamechar name #\/))
102    ;; Check that no unquoted wildcards.
103    (when (%path-mem-last "*" name)
104      (signal-file-error $xillwild name))
105    (namestring-unquote name)))
106
107;; Reverse of above, take native namestring and make a Lisp pathname.
108(defun native-to-pathname (name)
109  ;; This assumes that NAME is absolute and fully qualified, and
110  ;; that there'd be no benefit to (and some risk involved in)
111  ;; effectively merging it with whatever random thing may be
112  ;; in *DEFAULT-PATHNAME-DEFAULTS*.
113  ;; I -think- that that's true for all callers of this function.
114  (let* ((*default-pathname-defaults* #p""))
115    (pathname (%path-std-quotes name nil
116                                   #+windows-target "*;"
117                                   #-windows-target "*;:"))))
118
119(defun native-to-directory-pathname (name)
120  #+windows-target
121  (let* ((len (length name)))
122    (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/)
123                                  (eql (schar name (1- len)) #\\))))
124      (setq name (%str-cat name "/")))
125    (string-to-pathname name))
126  #-windows-target
127  (make-directory-pathname  :device nil :directory (%path-std-quotes name nil "*;:")))
128
129;;; Make a pathname which names the specified directory; use
130;;; explict :NAME, :TYPE, and :VERSION components of NIL.
131(defun make-directory-pathname (&key host device directory)
132  (make-pathname :host host
133                 :device device
134                 :directory directory
135                 :name nil
136                 :type nil
137                 :version nil))
138
139                   
140(defun namestring-unquote (name)
141  (let ((esc *pathname-escape-character*))
142    (multiple-value-bind (sstr start end) (get-sstring name)
143      (declare (simple-string sstr) (fixnum start end))
144      (let* ((ncopy 0)
145             (skipped nil)
146             (quote-next nil))
147        (declare (fixnum ncopy))
148        (do* ((i start (1+ i)))
149             ((= i end))
150          (declare (fixnum i))
151          (let* ((ch (schar sstr i)))
152            (cond ((or quote-next (not (eq ch esc)))
153                   (incf ncopy)
154                   (setq quote-next nil))
155                  ((eq ch esc) (setq skipped t) (setq quote-next t)))))
156        (if (not skipped)
157          name
158          (let ((result (make-string ncopy))
159                (dest 0))
160            (declare (fixnum dest))
161            (setq quote-next nil)
162            (do* ((i start (1+ i)))
163                 ((= i end) result)
164              (declare (fixnum i))
165              (let* ((ch (schar sstr i)))
166                (cond ((or quote-next (not (eq ch esc)))
167                       (setf (schar result dest) ch)
168                       (incf dest)
169                       (setq quote-next nil))
170                      ((eq ch esc) (setq quote-next t)))))))))))
171
172(defun translated-namestring (path)
173  (namestring (translate-logical-pathname (merge-pathnames path))))
174
175
176(defun truename (path)
177  "Return the pathname for the actual file described by PATHNAME.
178  An error of type FILE-ERROR is signalled if no such file exists,
179  or the pathname is wild.
180
181  Under Unix, the TRUENAME of a broken symlink is considered to be
182  the name of the broken symlink itself."
183  (or (probe-file path)
184      (signal-file-error $err-no-file path)))
185
186(defun check-pathname-not-wild (path)
187  (when (wild-pathname-p path)
188    (error 'file-error :error-type "Inappropriate use of wild pathname ~s"
189           :pathname path))
190  path)
191
192(defun probe-file (path)
193  "Return a pathname which is the truename of the file if it exists, or NIL
194  otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
195  (check-pathname-not-wild path)
196  (let* ((native (defaulted-native-namestring path))
197         (realpath (%realpath native))
198         (kind (if realpath (%unix-file-kind realpath))))
199    ;; Darwin's #_realpath will happily return non-nil for
200    ;; files that don't exist.  I don't think that
201    ;; %UNIX-FILE-KIND would do so.
202    (when kind
203      (if (eq kind :directory)
204          (unless (eq (aref realpath (1- (length realpath))) #\/)
205            (setq realpath (%str-cat realpath "/"))))
206      (if realpath
207        (native-to-pathname realpath)
208        nil))))
209
210(defun cwd (path) 
211  (multiple-value-bind (realpath kind) (%probe-file-x (defaulted-native-namestring path))
212    (if kind
213      (if (eq kind :directory)
214        (let* ((error (%chdir realpath)))
215          (if (eql error 0)
216            (mac-default-directory)
217            (signal-file-error error path)))
218        (error "~S is not a directory pathname." path))
219      (error "Invalid pathname : ~s." path))))
220
221(defun create-file (path &key (if-exists :error) (create-directory t))
222  (let* ((p (%create-file path :if-exists if-exists
223                                      :create-directory create-directory)))
224    (and p
225         (native-to-pathname p))))
226
227(defun %create-file (path &key
228                         (if-exists :error)
229                         (create-directory t))
230  (when create-directory
231    (create-directory path))
232  (when (directory-pathname-p path)
233    (return-from %create-file (probe-file-x path)))
234  (let* ((unix-name (defaulted-native-namestring path))
235         (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT
236                                        (if (eq if-exists :overwrite)
237                                          #$O_TRUNC
238                                          #$O_EXCL)))))
239    (when (and (neq if-exists :error)
240               (or (eql fd (- #$EEXIST))
241                   #+windows-target
242                   (and (eql fd (- #$EPERM))
243                        (probe-file path))))
244      (when (null if-exists)
245        (return-from %create-file nil))
246      (error "~s ~s not implemented yet" :if-exists if-exists))
247
248    (if (< fd 0)
249      (signal-file-error fd path)
250      (fd-close fd))
251    (%realpath unix-name)))
252
253
254;; The following assumptions are deeply embedded in all our pathname code:
255;; (1) Non-logical pathname host is always :unspecific.
256;; (2) Logical pathname host is never :unspecific.
257;; (3) Logical pathname host can however be NIL, e.g. "foo;bar;baz".
258
259(defun %pathname-host (pathname)
260  (if (logical-pathname-p pathname)
261      (%logical-pathname-host pathname)
262      :unspecific))
263
264(defun %pathname-version (pathname)
265  (if (logical-pathname-p pathname)
266    (%logical-pathname-version pathname)
267    (%physical-pathname-version pathname)))
268
269
270
271(fset 'pathname-host (nfunction bootstrapping-pathname-host   ; redefined later in this file
272                                (lambda (thing)
273                                  (declare (ignore thing))
274                                  :unspecific)))
275
276(fset 'pathname-version (nfunction bootstrapping-pathname-version   ; redefined later in this file
277                                   (lambda (thing)
278                                     (declare (ignore thing))
279                                     nil)))
280
281(defmethod print-object ((pathname pathname) stream)
282  (let ((flags (if (logical-pathname-p pathname) 4
283                   (%i+ (if (eq (%pathname-type pathname) ':unspecific) 1 0)
284                        (if (equal (%pathname-name pathname) "") 2 0))))
285        (name (namestring pathname)))
286    (if (and (not *print-readably*) (not *print-escape*))
287      (write-string name stream)
288      (progn
289        (format stream (if (or *print-escape* (eql flags 0)) "#P" "#~DP") flags)
290        (write-escaped-string name stream #\")))))
291
292
293(defun mac-default-directory ()
294  (let* ((native-name (current-directory-name))
295         (len (length native-name)))
296    (declare (fixnum len))
297    (when (and (> len 1)
298               (not (eq #\/ (schar native-name (1- len)))))
299      (setq native-name (%str-cat native-name "/")))
300    (native-to-pathname native-name)))
301
302
303
304
305;;; I thought I wanted to call this from elsewhere but perhaps not
306(defun absolute-directory-list (dirlist)
307  ; just make relative absolute and remove ups where possible
308  (when (or (null dirlist) (eq (car dirlist) :relative))
309    (let ((default (mac-default-directory)) default-dir)
310      (when default
311        (setq default-dir (%pathname-directory default))
312        (when default-dir
313          (setq dirlist (append default-dir (cdr dirlist)))))))
314  (when (memq :up dirlist)
315    (setq dirlist (remove-up (copy-list dirlist))))
316  dirlist)
317
318; destructively mungs dir
319(defun remove-up (dir)
320  (setq dir (delete "." dir  :test #'string=))
321  (let ((n 0)
322        (last nil)
323        (sub dir)
324        has-abs kept-up)
325    ;; from %std-directory-component we get dir with :relative/:absolute stripped
326    (when (memq :up dir)
327      (when (memq (car dir) '(:relative :absolute))
328        (setq sub (cdr dir) n 1 has-abs t))
329      (do () ((null sub))
330        (cond ((eq (car sub) :up)
331               (cond ((or (eq n 0)
332                          (and (stringp last)(string= last "**"))
333                          (eq last :wild-inferiors)
334                          kept-up
335                          (and has-abs (eq n 1)))
336                      ;; up after "**" stays, initial :up stays, how bout 2 :ups
337                      (setq kept-up t)
338                      )
339                     ((eq n 1) (setq dir (cddr dir) kept-up nil n -1))
340                     (t (rplacd (nthcdr (- n 2) dir) (cdr sub))
341                        (setq n (- n 2) kept-up nil))))
342              (t (setq kept-up nil)))
343        (setq last (car sub)
344              n (1+ n) 
345              sub (cdr sub))))
346    dir))
347
348(defun namestring (path)
349  "Construct the full (name)string form of the pathname."
350  (%str-cat (device-namestring path)
351            (host-namestring path)
352            (directory-namestring path)
353            (file-namestring path)))
354
355(defun device-namestring (path)
356  (let* ((device (pathname-device path)))
357    (if (and device (not (eq device :unspecific)))
358      (%str-cat device ":")
359      "")))
360
361(defun host-namestring (path)
362  "Return a string representation of the name of the host in the pathname."
363  (let ((host (pathname-host path)))
364    (if (and host (neq host :unspecific)) (%str-cat host ":") "")))
365
366(defun directory-namestring (path)
367  "Return a string representation of the directories used in the pathname."
368  (%directory-list-namestring (pathname-directory path)
369                              (neq (pathname-host path) :unspecific)))
370
371(defun ensure-directory-namestring (string)
372  (namestring (ensure-directory-pathname string)))
373
374(defun ensure-directory-pathname (pathname)
375  (let ((path (pathname pathname)))
376    (if (directory-pathname-p path)
377        path
378        (cons-pathname (append (or (pathname-directory path)
379                                   ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not
380                                   ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/").
381                                   (if (eq (pathname-host path) :unspecific)
382                                       '(:relative)
383                                       '(:absolute)))
384                               ;; Don't use file-namestring, because that
385                               ;; includes the version for logical names.
386                               (list (file-namestring-from-parts
387                                      (pathname-name path)
388                                      (pathname-type path)
389                                      nil)))
390                       nil nil (pathname-host path) nil #+windows-target (pathname-device path)))))
391
392(defun %directory-list-namestring (list &optional logical-p)
393  (if (null list)
394    ""
395    (let ((len (if (eq (car list) (if logical-p :relative :absolute)) 1 0))
396
397          result)
398      (declare (fixnum len)(optimize (speed 3)(safety 0)))
399      (dolist (s (%cdr list))
400        (case s
401          (:wild (setq len (+ len 2)))
402          (:wild-inferiors (setq len (+ len 3)))
403          (:up (setq len (+ len 3)))
404          (t ;This assumes that special chars in dir components are escaped,
405             ;otherwise would have to pre-scan for escapes here.
406           (setq len (+ len 1 (length s))))))
407      (setq result
408            (make-string len))
409      (let ((i 0)
410            (sep (if logical-p #\; #\/)))
411        (declare (fixnum i))
412        (when (eq (%car list) (if logical-p :relative :absolute))
413          (setf (%schar result 0) sep)
414          (setq i 1))
415        (dolist (s (%cdr list))
416          (case s
417            (:wild (setq s "*"))
418            (:wild-inferiors (setq s "**"))
419            ;; There is no :up in logical pathnames, so this must be native
420            (:up (setq s "..")))
421          (let ((len (length s)))
422            (declare (fixnum len))
423            (move-string-bytes s result 0 i len)
424            (setq i (+ i len)))
425          (setf (%schar result i) sep)
426          (setq i (1+ i))))
427      result)))
428
429(defun file-namestring (path)
430  "Return a string representation of the name used in the pathname."
431  (let* ((path (pathname path))
432         (name (pathname-name path))
433         (type (pathname-type path))
434         (version (if (typep path 'logical-pathname) (pathname-version path))))
435    (file-namestring-from-parts name type version)))
436
437(defun file-namestring-from-parts (name type version)
438  (when (eq version :unspecific) (setq version nil))
439  (when (eq type :unspecific) (setq type nil))
440  (%str-cat (case name
441              ((nil :unspecific) "")
442              (:wild "*")
443              (t (%path-std-quotes name "*;:" ".")))
444            (if (or type version)
445              (%str-cat (case type
446                          ((nil) ".")
447                          (:wild ".*")
448                          (t (%str-cat "." (%path-std-quotes type "*;:" "."))))
449                        (case version
450                          ((nil) "")
451                          (:newest ".newest")
452                          (:wild ".*")
453                          (t (%str-cat "." (if (fixnump version)
454                                             (%integer-to-string version)
455                                             version)))))
456              "")))
457
458(defun enough-namestring (path &optional (defaults *default-pathname-defaults*))
459  "Return an abbreviated pathname sufficent to identify the pathname relative
460   to the defaults."
461  (if (null defaults)
462    (namestring path)
463    (let* ((dir (pathname-directory path))
464           (nam (pathname-name path))
465           (typ (pathname-type path))
466           (ver (pathname-version path))
467           (host (pathname-host path))
468           (logical-p (neq host :unspecific))
469           (default-dir (pathname-directory defaults)))
470      ;; enough-host-namestring
471      (setq host (if (and host
472                          (neq host :unspecific)
473                          (not (equalp host (pathname-host defaults))))
474                   (%str-cat host ":")
475                   ""))
476      ;; enough-directory-namestring
477      (cond ((equalp dir default-dir)
478             (setq dir '(:relative)))
479            ((and dir default-dir
480                  (eq (car dir) :absolute) (eq (car default-dir) :absolute))
481             ;; maybe make it relative to defaults             
482             (do ((p1 (cdr dir) (cdr p1))
483                  (p2 (cdr default-dir) (cdr p2)))
484                 ((or (null p2) (null p1) (not (equalp (car p1) (car p2))))
485                  (when (and (null p2) (or t (neq p1 (cdr dir))))
486                    (setq dir (cons :relative p1)))))))
487      (setq dir (%directory-list-namestring dir logical-p))
488      ;; enough-file-namestring
489      (when (or (equalp ver (pathname-version defaults))
490                (not logical-p))
491        (setq ver nil))
492      (when (and (null ver) (equalp typ (pathname-type defaults)))
493        (setq typ nil))
494      (when (and (null typ) (equalp nam (pathname-name defaults)))
495        (setq nam nil))
496      (setq nam (file-namestring-from-parts nam typ ver))
497      (%str-cat host dir nam))))
498
499(defun cons-pathname (dir name type &optional host version device)
500  (if (neq host :unspecific)
501    (%cons-logical-pathname dir name type host version)
502    (%cons-pathname dir name type version device)))
503
504(defun pathname (path)
505  "Convert thing (a pathname, string or stream) into a pathname."
506  (etypecase path
507    (pathname path)
508    (stream (%path-from-stream path))
509    (string (string-to-pathname path))))
510
511(defun %path-from-stream (stream)
512  (or (pathname (stream-filename stream))
513      (error "Can't determine pathname of ~S ." stream)))      ; ???
514
515;Like (pathname stream) except returns NIL rather than error when there's no
516;filename associated with the stream.
517(defun stream-pathname (stream &aux (path (stream-filename stream)))
518  (when path (pathname path)))
519
520(defun get-pathname-sstring (string &optional (start 0) (end (length string)))
521  #-windows-target
522  (get-sstring string start end)
523  #+windows-target
524  (multiple-value-bind (sstr start end)
525      (get-sstring string start end)
526    (declare (fixnum start end)
527             (simple-string sstr))
528    (if (do* ((i start (1+ i)))
529             ((= i end))
530          (declare (fixnum i))
531          (when (eql (schar sstr i) #\\)
532            (return t)))
533      (let* ((len (- end start))
534             (new (make-string len)))
535        (declare (fixnum len) (simple-string new))
536        (dotimes (i len)
537          (let* ((ch (schar sstr start)))
538            (if (eql ch #\\)
539              (setf (schar new i) #\/)
540              (setf (schar new i) ch)))
541          (incf start))
542        (values new 0 len))
543      (values sstr start end))))
544             
545(defun string-to-pathname (string &optional (start 0) (end (length string))
546                                            (reference-host nil)
547                                            (defaults *default-pathname-defaults*))
548  (require-type reference-host '(or null string))
549  (multiple-value-bind (sstr start end) (get-pathname-sstring string start end)
550    (if (and (> end start)
551             (eql (schar sstr start) #\~))
552      (setq sstr (tilde-expand (subseq sstr start end))
553            start 0
554            end (length sstr)))
555    (let (directory name type host version device (start-pos start) (end-pos end) has-slashes)
556      (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos))
557      (cond ((and host (neq host :unspecific))
558             (when (and reference-host (not (string-equal reference-host host)))
559               (error "Host in ~S does not match requested host ~S"
560                      (%substr sstr start end) reference-host)))
561            ((or reference-host
562                 (and defaults
563                      (neq (setq reference-host (pathname-host defaults)) :unspecific)))
564             ;;If either a reference-host is specified or defaults is a logical pathname
565             ;; then the string must be interpreted as a logical pathname.
566             (when has-slashes
567               (error "Illegal logical namestring ~S" (%substr sstr start end)))
568             (setq host reference-host)))
569      #+windows-target
570      (when (and (eq host :unspecific)
571                 (eql start-pos 0)
572                 (eql (position #\: sstr) 1))
573        (let* ((ch (schar sstr 0)))
574          (when (and (alpha-char-p ch)
575                     (standard-char-p ch))
576            (setq device (make-string 1 :initial-element ch)
577                  start-pos 2))))
578      (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host))
579      (unless (eq host :unspecific)
580        (multiple-value-setq (version end-pos) (pathname-version-sstr sstr start-pos end-pos)))
581      (multiple-value-setq (type end-pos) (pathname-type-sstr sstr start-pos end-pos))
582      ;; now everything else is the name
583      (unless (eq start-pos end-pos)
584        (setq name (%std-name-component (%substr sstr start-pos end-pos))))
585      (if (eq host :unspecific)
586        (%cons-pathname directory name type (if name :newest) device)
587        (%cons-logical-pathname directory name type host version)))))
588
589(defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*)
590                               &key (start 0) end junk-allowed)
591  (declare (ignore junk-allowed))
592  (unless (typep thing 'string)
593    (let* ((path (pathname thing))
594           (pathname-host (pathname-host path)))
595      (when (and host pathname-host
596                 (or (eq pathname-host :unspecific) ;physical
597                     (not (string-equal host pathname-host))))
598        (error "Host in ~S does not match requested host ~S" path host))
599      (return-from parse-namestring (values path start))))
600  (when host
601    (verify-logical-host-name host))
602  (setq end (check-sequence-bounds thing start end))
603  (values (string-to-pathname thing start end host defaults) end))
604
605
606
607(defun %std-device-component (device host)
608  (when (and (or (null host) (eq host :unspecific))
609             (and device (not (eq device :unspecific))))
610    #+windows-target
611    (unless (and (typep device 'string)
612                 (eql (length device) 1)
613                 (alpha-char-p (char device 0))
614                 (standard-char-p (char device 0)))
615      (error "Invalid pathname device ~s" device))
616    device))
617   
618(defun make-pathname (&key (host nil host-p) 
619                           (device nil device-p)
620                           (directory nil directory-p)
621                           (name nil name-p)
622                           (type nil type-p)
623                           (version nil version-p)
624                           (defaults nil defaults-p) case
625                           &aux path)
626  "Makes a new pathname from the component arguments. Note that host is
627a host-structure or string."
628  (when case (setq case (require-type case pathname-case-type)))
629  (if (null host-p)
630    (let ((defaulted-defaults (if defaults-p defaults *default-pathname-defaults*)))
631      (setq host (if defaulted-defaults
632                   (pathname-host defaulted-defaults)
633                   :unspecific)))
634    (unless host (setq host :unspecific)))
635  (if directory-p 
636    (setq directory (%std-directory-component directory host)))
637  (if (and defaults (not directory-p))
638    (setq directory (pathname-directory defaults)))
639  (if (and defaults (not device-p))
640    (setq device (pathname-device defaults)))
641  (setq device (%std-device-component device host))
642  (setq name
643        (if name-p
644             (%std-name-component name)
645             (and defaults (pathname-name defaults))))
646  (setq type
647        (if type-p
648             (%std-type-component type)
649             (and defaults (pathname-type defaults))))
650  (setq version (if version-p
651                  (%logical-version-component version)
652                  (if name-p
653                    nil
654                    (and defaults (pathname-version defaults)))))
655  (setq path
656        (if (eq host :unspecific)
657          (%cons-pathname directory name type version device)
658          (%cons-logical-pathname
659           (or directory
660               (unless directory-p '(:absolute)))
661           name type host version)))
662  (when (and (eq (car directory) :absolute)
663             (member (cadr directory) '(:up :back)))
664    (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory))))
665  (let* ((after-wif (cadr (member :wild-inferiors directory))))
666    (when (member after-wif '(:up :back))
667          (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif))))
668         
669  (when (and case (neq case :local))
670    (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case)
671          (%pathname-name path) (%reverse-component-case (%pathname-name path) case)
672          (%pathname-type path) (%reverse-component-case (%pathname-type path) case)))
673  path)
674
675;;;  In portable CL, if the :directory argument to make pathname is a
676;;;  string, it should be the name of a top-level directory and should
677;;;  not contain any punctuation characters such as "/" or ";".  In
678;;;  MCL a string :directory argument with slashes or semi-colons will
679;;;  be parsed as a directory in the obvious way.
680(defun %std-directory-component (directory host)
681  (cond ((null directory) nil)
682        ((eq directory :wild) '(:absolute :wild-inferiors))
683        ((stringp directory) (%directory-string-list directory 0 (length directory) host))
684        ((listp directory)
685         ;Standardize the directory list, taking care not to cons if nothing
686         ;needs to be changed.
687         (let ((names (%cdr directory)) (new-names ()))
688           (do ((nn names (%cdr nn)))
689               ((null nn) (setq new-names (if new-names (nreverse new-names) names)))
690             (let* ((name (car nn))
691                    (new-name (%std-directory-part name)))
692               (unless (eq name new-name)
693                 (unless new-names
694                   (do ((new-nn names (%cdr new-nn)))
695                       ((eq new-nn nn))
696                     (push (%car new-nn) new-names))))
697               (when (or new-names (neq name new-name))
698                 (push new-name new-names))))
699           (when (memq :up (or new-names names))
700             (setq new-names (remove-up (copy-list (or new-names names)))))
701           (ecase (%car directory)
702             (:relative           
703                  (cond (new-names         ; Just (:relative) is the same as NIL. - no it isnt
704                         (if (eq new-names names)
705                           directory
706                           (cons ':relative new-names)))
707                        (t directory)))
708             (:absolute
709                  (cond ((null new-names) directory)  ; But just (:absolute) IS the same as NIL
710                        ((eq new-names names) directory)
711                        (t (cons ':absolute new-names)))))))
712        (t (report-bad-arg directory '(or string list (member :wild))))))
713
714(defun %std-directory-part (name)
715  (case name
716    ((:wild :wild-inferiors :up) name)
717    (:back :up)
718    (t (cond ((string= name "*") :wild)
719             ((string= name "**") :wild-inferiors)
720             ((string= name "..") :up)
721             (t (%path-std-quotes name "/:;*" "/:;"))))))
722
723; this will allow creation of garbage pathname "foo:bar;bas:" do we care?
724(defun merge-pathnames (path &optional (defaults *default-pathname-defaults*)
725                                       (default-version :newest))
726  "Construct a filled in pathname by completing the unspecified components
727   from the defaults."
728  ;(declare (ignore default-version))
729  (when (not (pathnamep path))(setq path (pathname path)))
730  (when (and defaults (not (pathnamep defaults)))(setq defaults (pathname defaults)))
731  (let* ((path-dir (pathname-directory path))
732         (path-host (pathname-host path))
733         (path-name (pathname-name path))
734         (path-type (pathname-type path))
735         (path-device (pathname-device path))
736         (default-dir (and defaults (pathname-directory defaults)))
737         (default-host (and defaults (pathname-host defaults)))
738         (default-device (and defaults (pathname-device defaults)))
739         ; take host from defaults iff path-dir is logical or absent - huh?
740         (host (cond ((or (null path-host)  ; added 7/96
741                          (and (eq path-host :unspecific)
742                               (or (null path-dir)
743                                   (null (cdr path-dir))
744                                   (and (eq :relative (car path-dir))
745                                        (not (memq default-host '(nil :unspecific)))))))
746                         
747                      default-host)
748                     (t  path-host)))
749         (dir (cond ((null path-dir) default-dir)
750                    ((null default-dir) path-dir)
751                    ((eq (car path-dir) ':relative)
752                     (let ((the-dir (append default-dir (%cdr path-dir))))
753                       (when (memq ':up the-dir)(setq the-dir (remove-up (copy-list the-dir))))
754                       the-dir))
755                    (t path-dir)))
756         (nam (or path-name
757                  (and defaults (pathname-name defaults))))
758         (typ (or path-type
759                  (and defaults (pathname-type defaults))))
760         (version (or (pathname-version path)
761                      (cond ((not path-name)
762                             (or (and defaults (pathname-version defaults))
763                                 default-version))
764                            (t default-version))))
765         (device (or path-device default-device)))
766    (if (and (pathnamep path)
767             (eq dir (%pathname-directory path))
768             (eq nam path-name)
769             (eq typ (%pathname-type path))
770             (eq host path-host)
771             (eq device path-device)
772             (eq version (pathname-version path)))
773      path 
774      (cons-pathname dir nam typ host version device))))
775
776(defun directory-pathname-p (path)
777  (let ((name (pathname-name path))(type (pathname-type path)))
778    (and  (or (null name) (eq name :unspecific) (%izerop (length name)))
779          (or (null type) (eq type :unspecific)))))
780
781;In CCL, a pathname is logical if and only if pathname-host is not :unspecific.
782(defun pathname-host (thing &key case)
783  "Return PATHNAME's host."
784  (when (streamp thing)(setq thing (%path-from-stream thing)))
785  (when case (setq case (require-type case pathname-case-type)))
786  (let ((name
787         (typecase thing   
788           (logical-pathname (%logical-pathname-host thing))
789           (pathname :unspecific)
790           (string (multiple-value-bind (sstr start end) (get-pathname-sstring thing) 
791                     (pathname-host-sstr sstr start end)))
792           (t (report-bad-arg thing pathname-arg-type)))))
793    (if (and case (neq case :local))
794      (progn
795        (when (and (eq case :common) (neq name :unspecific)) (setq case :logical))
796        (%reverse-component-case name case))
797      name)))
798
799(defun pathname-host-sstr (sstr start end &optional no-check)
800  ;; A pathname with any (unescaped) /'s is always a physical pathname.
801  ;; Otherwise, if the pathname has either a : or a ;, then it's always logical.
802  ;; Otherwise, it's probably physical.
803  ;; Return :unspecific for physical, host string or nil for a logical.
804  (let* ((slash (%path-mem "/" sstr start end))
805         (pos (and (not slash) (%path-mem ":;" sstr start end)))
806         (pos-char (and pos (%schar sstr pos)))
807         (host (and (eql pos-char #\:) (%substr sstr start pos))))
808    (cond (host
809           (unless (or no-check (logical-host-p host))
810             (error "~S is not a defined logical host" host))
811           (values host (%i+ pos 1) nil))
812          ((eql pos-char #\;) ; logical pathname with missing host
813           (values nil start nil))
814          (t ;else a physical pathname.
815           (values :unspecific start slash)))))
816
817
818(defun pathname-device (thing &key case)
819  "Return PATHNAME's device."
820  (declare (ignore case))
821  (let* ((p (pathname thing)))
822    (etypecase p
823      (logical-pathname :unspecific)
824      (pathname (%physical-pathname-device p)))))
825
826
827
828;A directory is either NIL or a (possibly wildcarded) string ending in "/" or ";"
829;Quoted /'s are allowed at this stage, though will get an error when go to the
830;filesystem.
831(defun pathname-directory (path &key case)
832  "Return PATHNAME's directory."
833  (when (streamp path) (setq path (%path-from-stream path)))
834  (when case (setq case (require-type case pathname-case-type)))
835  (let* ((logical-p nil)
836         (names (typecase path
837                  (logical-pathname (setq logical-p t) (%pathname-directory path))
838                  (pathname (%pathname-directory path))
839                  (string
840                   (multiple-value-bind (sstr start end) (get-pathname-sstring path)
841                     (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
842                       (unless (eq host :unspecific) (setq logical-p t))
843                       #+windows-target
844                       (unless logical-p
845                         (if (and (> end 1)
846                                  (eql (schar sstr 1) #\:))
847                           (setq pos2 2)))
848                       (pathname-directory-sstr sstr pos2 end host))))
849                  (t (report-bad-arg path pathname-arg-type)))))
850    (if (and case (neq case :local))
851      (progn
852        (when (and (eq case :common) logical-p) (setq case :logical))
853        (%reverse-component-case names case))
854      names)))
855
856;; Must match pathname-directory-end below
857(defun pathname-directory-sstr (sstr start end host)
858  (if (and (eq host :unspecific)
859           (> end start)
860           (eql (schar sstr start) #\~))
861    (setq sstr (tilde-expand (subseq sstr start end))
862          start 0
863          end (length sstr)))
864  (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr start end)))
865    (if pos
866      (values 
867       (%directory-string-list sstr start (setq pos (%i+ pos 1)) host)
868       pos)
869      (values (and (neq host :unspecific)
870                   ;;(neq start end)
871                   '(:absolute))
872              start))))
873
874;; Must match pathname-directory-sstr above
875(defun pathname-directory-end (sstr start end)
876  (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
877    (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr pos2 end)))
878      (if pos
879        (values (%i+ pos 1) host)
880        (values pos2 host)))))
881
882(defun %directory-string-list (sstr start &optional (end (length sstr)) host)
883  ;; Should use host to split by / vs. ; but for now suport both for either host,
884  ;; like the mac version. It means that ';' has to be quoted in unix pathnames.
885  (declare (ignore host))
886  ;This must cons up a fresh list, %expand-logical-directory rplacd's it.
887  (labels ((std-part (sstr start end)
888             (%std-directory-part (if (and (eq start 0) (eq end (length sstr)))
889                                    sstr (%substr sstr start end))))
890           (split (sstr start end)
891             (unless (eql start end)
892               (let ((pos (%path-mem "/;" sstr start end)))
893                 (if (eq pos start)
894                   (split sstr (%i+ start 1) end) ;; treat multiple ////'s as one.
895                   (cons (std-part sstr start (or pos end))
896                         (when pos
897                           (split sstr (%i+ pos 1) end))))))))
898    (unless (eq start end)
899      (let* ((slash-pos (%path-mem "/" sstr start end))
900             (semi-pos (%path-mem ";" sstr start end))
901             (pos (or slash-pos semi-pos)))
902        ; this never did anything sensible but did not signal an error
903        (when (and slash-pos semi-pos)
904          (error "Illegal directory string ~s" (%substr sstr start end)))
905        (if (null pos)
906          (list :relative (std-part sstr start end))
907          (let ((pos-char (%schar sstr pos)))
908            (cons (if (eq pos start)
909                    (if (eq pos-char #\/) ':absolute ':relative)
910                    (if (eq pos-char #\/) ':relative ':absolute))
911                  (split sstr start end))))))))
912
913(defun pathname-version (path)
914  "Return PATHNAME's version."
915  (when (streamp path) (setq path (%path-from-stream path)))
916  (typecase path
917    (logical-pathname (%logical-pathname-version path))
918    (pathname (%physical-pathname-version path))
919    (string
920     (multiple-value-bind (sstr start end) (get-pathname-sstring path)
921       (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
922         (if (eq host :unspecific)
923           nil
924           (values (pathname-version-sstr sstr newstart end))))))
925    (t (report-bad-arg path pathname-arg-type))))
926
927(defun pathname-version-sstr (sstr start end)
928  (declare (fixnum start end))
929  (let ((pos (%path-mem-last "." sstr start end)))
930    (if (and pos (%i> pos start) (%path-mem "." sstr start (%i- pos 1)))
931      (values (%std-version-component (%substr sstr (%i+ pos 1) end)) pos)
932      (values nil end))))
933
934(defun %std-version-component (v)
935  (cond ((or (null v) (eq v :unspecific)) v)
936        ((eq v :wild) "*")
937        ((string= v "") :unspecific)
938        ((string-equal v "newest") :newest)
939        ((every #'digit-char-p v) (parse-integer v))
940        (t (%path-std-quotes v "./:;*" "./:;"))))
941
942
943;A name is either NIL or a (possibly wildcarded, possibly empty) string.
944;Quoted /'s are allowed at this stage, though will get an error if go to the
945;filesystem.
946(defun pathname-name (path &key case)
947  "Return PATHNAME's name."
948  (when (streamp path) (setq path (%path-from-stream path)))
949  (when case (setq case (require-type case pathname-case-type)))
950  (let* ((logical-p nil)
951         (name (typecase path
952                 (logical-pathname (setq logical-p t) (%pathname-name path))
953                 (pathname (%pathname-name path))
954                 (string
955                  (multiple-value-bind (sstr start end) (get-pathname-sstring path)
956                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
957                      (setq start newstart)
958                      (unless (eq host :unspecific)
959                        (setq logical-p t)
960                        (setq end (nth-value 1 (pathname-version-sstr sstr start end))))
961                      ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type.
962                      ;;   -->> Need to make an exception so that foo/.. is a directory pathname,
963                      ;; for native.
964                      (setq end (or (%path-mem-last "." sstr start end) end));; strip off type
965                      (unless (eq start end)
966                        (%std-name-component (%substr sstr start end))))))
967                 (t (report-bad-arg path pathname-arg-type)))))
968    (if (and case (neq case :local))
969      (progn
970        (when (and (eq case :common) logical-p) (setq case :logical))
971        (%reverse-component-case name case))
972      name)))
973
974(defun %std-name-component (name)
975  (cond ((or (null name) (eq name :unspecific) (eq name :wild)) name)
976        ((equal name "*") :wild)
977        (t (%path-std-quotes name "/:;*" "/:;"))))
978
979;A type is either NIL or a (possibly wildcarded, possibly empty) string.
980;Quoted :'s are allowed at this stage, though will get an error if go to the
981;filesystem.
982(defun pathname-type (path &key case)
983  "Return PATHNAME's type."
984  (when (streamp path) (setq path (%path-from-stream path)))
985  (when case (setq case (require-type case pathname-case-type)))
986  (let* ((logical-p nil)
987         (name (typecase path
988                 (logical-pathname (setq logical-p t) (%pathname-type path))
989                 (pathname (%pathname-type path))
990                 (string
991                  (multiple-value-bind (sstr start end) (get-pathname-sstring path)
992                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
993                      (setq start newstart)
994                      (unless (eq host :unspecific)
995                        (setq logical-p t)
996                        (setq end (nth-value 1 (pathname-version-sstr sstr start end))))
997                      ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type.
998                      ;;   -->> Need to make an exception so that foo/.. is a directory pathname,
999                      ;; for native.
1000                      (pathname-type-sstr sstr start end))))
1001                 (t (report-bad-arg path pathname-arg-type)))))
1002    (if (and case (neq case :local))
1003      (progn
1004        (when (and (eq case :common) logical-p) (setq case :logical))
1005        (%reverse-component-case name case))
1006      name)))
1007
1008; assumes dir & version if any has been stripped away
1009(defun pathname-type-sstr (sstr start end)
1010  (let ((pos (%path-mem-last "." sstr start end)))
1011    (if pos
1012      (values (%std-type-component (%substr sstr (%i+ 1 pos) end)) pos)
1013      (values nil end))))
1014
1015(defun %std-type-component (type)
1016  (cond ((or (null type) (eq type :unspecific) (eq type :wild)) type)
1017        ((equal type "*") :wild)
1018        (t (%path-std-quotes type "./:;*" "./:;"))))
1019
1020(defun %std-name-and-type (native)
1021  (let* ((end (length native))
1022         (pos (position #\. native :from-end t))
1023         (type (and pos
1024                    (%path-std-quotes (%substr native (%i+ 1 pos) end)
1025                                      nil "/:;*")))
1026         (name (unless (eq (or pos end) 0)
1027                 (%path-std-quotes (if pos (%substr native 0 pos) native)
1028                                   nil "/:;*"))))
1029    (values name type)))
1030
1031(defun %reverse-component-case (name case)
1032  (cond ((not (stringp name))
1033         (if (listp name)
1034           (mapcar #'(lambda (name) (%reverse-component-case name case))  name)
1035           name))
1036        #+advanced-studlification-feature
1037        ((eq case :studly) (string-studlify name))
1038        ((eq case :logical)
1039         (if (every #'(lambda (ch) (not (lower-case-p ch))) name)
1040           name
1041           (string-upcase name)))
1042        (t ; like %read-idiocy but non-destructive - need it be?
1043         (let ((which nil)
1044               (len (length name)))
1045           (dotimes (i len)
1046             (let ((c (%schar name i)))
1047               (if (alpha-char-p c)
1048                 (if (upper-case-p c)
1049                   (progn
1050                     (when (eq which :lower)(return-from %reverse-component-case name))
1051                     (setq which :upper))
1052                   (progn
1053                     (when (eq which :upper)(return-from %reverse-component-case name))
1054                     (setq which :lower))))))
1055           (case which
1056             (:lower (string-upcase name))
1057             (:upper (string-downcase name))
1058             (t name))))))
1059
1060;;;;;;; String-with-quotes utilities
1061(defun %path-mem-last-quoted (chars sstr &optional (start 0) (end (length sstr)))
1062  (while (%i< start end)
1063    (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars)
1064               (%path-quoted-p sstr end start))
1065      (return-from %path-mem-last-quoted end))))
1066
1067(defun %path-mem-last (chars sstr &optional (start 0) (end (length sstr)))
1068  (while (%i< start end)
1069    (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars)
1070               (not (%path-quoted-p sstr end start)))
1071      (return-from %path-mem-last end))))
1072
1073(defun %path-mem (chars sstr &optional (start 0) (end (length sstr)))
1074  (let ((one-char (when (eq (length chars) 1) (%schar chars 0))))
1075    (while (%i< start end)
1076      (let ((char (%schar sstr start)))
1077        (when (if one-char (eq char one-char)(%%str-member char chars))
1078          (return-from %path-mem start))
1079        (when (eq char *pathname-escape-character*)
1080          (setq start (%i+ start 1)))
1081        (setq start (%i+ start 1))))))
1082
1083; these for \:  meaning this aint a logical host. Only legal for top level dir
1084 
1085(defun %path-unquote-one-quoted (chars sstr &optional (start 0)(end (length sstr)))
1086  (let ((pos (%path-mem-last-quoted chars sstr start end)))
1087    (when (and pos (neq pos 1))
1088      (cond ((or (%path-mem chars sstr start (1- pos))
1089                 (%path-mem-last-quoted chars sstr start (1- pos)))
1090             nil)
1091            (t (%str-cat (%substr sstr start (1- pos))(%substr sstr  pos end)))))))
1092
1093(defun %path-one-quoted-p (chars sstr &optional (start 0)(end (length sstr)))
1094  (let ((pos (%path-mem-last-quoted chars sstr start end)))
1095    (when (and pos (neq pos 1))
1096      (not (or (%path-mem-last-quoted chars sstr start (1- pos))
1097               (%path-mem chars sstr start (1- pos)))))))
1098 
1099(defun %path-quoted-p (sstr pos start &aux (esc *pathname-escape-character*) (q nil))
1100  (while (and (%i> pos start) (eq (%schar sstr (setq pos (%i- pos 1))) esc))
1101    (setq q (not q)))
1102  q)
1103
1104
1105
1106;Standardize pathname quoting, so can do EQUAL.
1107;; Subtle point: when keep-quoted is NIL, arg is assumed native,
1108;; and therefore escape characters are made quoted.
1109;; if keep-quoted is not NIL, e.g. if it's "", arg is assumed
1110;;   to be escaped already, so escape chars are interpreted as quotes.
1111;; Note that this can't be used to remove quotes because it
1112;; always keeps the escape character quoted.
1113(defun %path-std-quotes (arg keep-quoted make-quoted)
1114  (when (symbolp arg)
1115    (error "Invalid pathname component ~S" arg))
1116  (let* ((str arg)
1117         (esc *pathname-escape-character*)
1118         (end (length str))
1119         res-str char)
1120    (multiple-value-bind (sstr start)(array-data-and-offset str)
1121      (setq end (+ start end))
1122      (let ((i start))
1123        (until (eq i end)
1124          (setq char (%schar sstr i))
1125          (cond ((or (%%str-member char make-quoted)
1126                     (and (null keep-quoted) (eq char esc)))
1127                 (unless res-str
1128                   (setq res-str (make-array (%i- end start)
1129                                             :element-type (array-element-type sstr)
1130                                             :adjustable t :fill-pointer 0))
1131                   (do ((j start (%i+ j 1))) ((eq j i))
1132                     (vector-push-extend (%schar sstr j) res-str)))
1133                 (vector-push-extend esc res-str))
1134                ((neq char esc) nil)
1135                ((eq (setq i (%i+ i 1)) end)
1136                 (error "Malformed pathname component string ~S" str))
1137                ((or (eq (setq char (%schar sstr i)) esc)
1138                     (%%str-member char keep-quoted))
1139                 (when res-str (vector-push-extend esc res-str)))
1140                (t
1141                 (unless res-str
1142                   (setq res-str (make-array (%i- end start)
1143                                             :element-type (array-element-type sstr)
1144                                             :adjustable t :fill-pointer 0))
1145                   (do ((j start (%i+ j 1)) (end (%i- i 1))) ((eq j end))
1146                     (vector-push-extend (%schar sstr j) res-str)))))
1147          (when res-str (vector-push-extend char res-str))
1148          (setq i (%i+ i 1)))
1149        (ensure-simple-string (or res-str str))))))
1150
1151
1152
1153(defun %%str-member (char string)
1154  (locally (declare (optimize (speed 3)(safety 0)))
1155    (dotimes (i (the fixnum (length string)))
1156      (when (eq (%schar string i) char)
1157        (return i)))))
1158
1159
1160(defun file-write-date (path)
1161  "Return file's creation date, or NIL if it doesn't exist.
1162  An error of type file-error is signaled if file is a wild pathname"
1163  (%file-write-date (defaulted-native-namestring path)))
1164
1165(defun file-author (path)
1166  "Return the file author as a string, or NIL if the author cannot be
1167  determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
1168  or FILE is a wild pathname."
1169  (%file-author (defaulted-native-namestring path)))
1170
1171(defun touch (path)
1172  (if (not (probe-file path))
1173    (progn
1174      (ensure-directories-exist path)
1175      (if (or (pathname-name path)
1176              (pathname-type path))
1177        (create-file path)))
1178    (%utimes (defaulted-native-namestring path)))
1179  t)
1180
1181
1182;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
1183; load, require, provide
1184
1185(defun find-load-file (file-name)
1186  (let ((full-name (full-pathname file-name :no-error nil))
1187        (kind nil))
1188    (when full-name
1189      (let ((file-type (pathname-type full-name))
1190            (merged (pathname (merge-pathnames file-name))))
1191        (if (and file-type (neq file-type :unspecific))
1192          (values (probe-file full-name) merged (if (eq (pathname-host file-name) :unspecific) full-name file-name))
1193          (let* ((source (merge-pathnames file-name *.lisp-pathname*))
1194                 (fasl   (merge-pathnames file-name *.fasl-pathname*))
1195                 (true-source (probe-file source))
1196                 (true-fasl   (probe-file fasl)))
1197            (cond (true-source
1198                   (if (and true-fasl
1199                            (> (file-write-date true-fasl)
1200                               (file-write-date true-source)))
1201                     (values true-fasl merged source)
1202                     (values true-source merged source)))
1203                  (true-fasl
1204                   (values true-fasl merged fasl))
1205                  ((and (multiple-value-setq (full-name kind)
1206                          (let* ((realpath (%realpath (defaulted-native-namestring full-name))))
1207                            (if realpath
1208                              (%probe-file-x realpath ))))
1209                        (eq kind :file))
1210                   (values full-name merged file-name)))))))))
1211
1212
1213
1214
1215
1216(defun load (file-name &key (verbose *load-verbose*)
1217                       (print *load-print*)
1218                       (if-does-not-exist :error)
1219                       (external-format :default)
1220                       (preserve-optimization-settings *load-preserves-optimization-settings*))
1221  "Load the file given by FILESPEC into the Lisp environment, returning
1222   T on success.
1223
1224   Extension: :PRINT :SOURCE means print source as well as value"
1225  (loop
1226    (restart-case
1227     (return (%load file-name verbose print if-does-not-exist external-format preserve-optimization-settings))
1228      (retry-load ()
1229                  :report (lambda (stream) (format stream "Retry loading ~s" file-name)))
1230      (skip-load ()
1231                 :report (lambda (stream) (format stream "Skip loading ~s" file-name))
1232                 (return nil))
1233      (load-other ()
1234                  :report (lambda (stream) (format stream "Load other file instead of ~s" file-name))
1235                  (return
1236                   (load (choose-file-dialog)
1237                         :verbose verbose
1238                         :print print
1239                         :if-does-not-exist if-does-not-exist))))))
1240
1241
1242(defun %load (file-name verbose print if-does-not-exist external-format preserve-optimization-settings)
1243  (let ((*load-pathname* file-name)
1244        (*load-truename* file-name)
1245        (source-file file-name)
1246        (optimization-setting-vars '(*nx-speed* *nx-space* *nx-safety*
1247                                     *nx-debug* *nx-cspeed*)))
1248    (declare (special *load-pathname* *load-truename*))
1249    (progv
1250        (if preserve-optimization-settings optimization-setting-vars)
1251        (if preserve-optimization-settings (mapcar #'symbol-value optimization-setting-vars))
1252    (when (typep file-name 'string-input-stream)
1253      (when verbose
1254          (format t "~&;Loading from stream ~S..." file-name)
1255          (force-output))
1256      (let ((*package* *package*)
1257            (*readtable* *readtable*))
1258        (load-from-stream file-name print))
1259      (return-from %load file-name))
1260    (when (and (stringp file-name)
1261               (eql (length "http://") (string-lessp "http://" file-name)))
1262      (when verbose
1263        (format t "~&;Loading from URL ~S..." file-name)
1264        (force-output))
1265      (let* ((vec (if if-does-not-exist
1266                    (snarf-url file-name)
1267                    (handler-case (snarf-url file-name)
1268                      (error () (return-from %load nil)))))
1269             (*package* *package*)
1270             (*readtable* *readtable*)
1271             (*loading-file-source-file* file-name)
1272             (*loading-files* (cons file-name (specialv *loading-files*))))
1273        (with-input-from-vector (stream vec :external-format external-format)
1274          (load-from-stream stream print)))
1275      (return-from %load file-name))
1276    (unless (streamp file-name)
1277      (multiple-value-setq (*load-truename* *load-pathname* source-file)
1278        (find-load-file (merge-pathnames file-name)))
1279      (when (not *load-truename*)
1280        (return-from %load (if if-does-not-exist
1281                             (signal-file-error $err-no-file file-name))))
1282      (setq file-name *load-truename*))
1283    (let* ((*package* *package*)
1284           (*readtable* *readtable*)
1285           (*loading-files* (cons file-name (specialv *loading-files*)))
1286           ;;reset by fasload to logical name stored in the file
1287           (*loading-file-source-file* (namestring source-file))
1288           (*loading-toplevel-location* nil))
1289      (declare (special *loading-files* *loading-file-source-file*))
1290      (when verbose
1291        (format t "~&;Loading ~S..." *load-pathname*)
1292        (force-output))
1293      (cond ((fasl-file-p file-name)
1294             (let ((*fasload-print* print)
1295                   (restart-setup nil)
1296                   (restart-source nil)
1297                   (restart-fasl nil))
1298               (declare (special *fasload-print*))
1299               (flet ((restart-test (c)
1300                        (unless restart-setup
1301                          (setq restart-setup t)
1302                          (let ((source *loading-file-source-file*)
1303                                (fasl *load-pathname*))
1304                            (when (and (not (typep c 'file-error))
1305                                       source
1306                                       fasl
1307                                       (setq source (probe-file source))
1308                                       (setq fasl (probe-file fasl))
1309                                       (not (equalp source fasl)))
1310                              (setq restart-fasl (namestring *load-pathname*)
1311                                    restart-source *loading-file-source-file*))))
1312                        (not (null restart-fasl)))
1313                      (fname (p)
1314                        #-versioned-file-system
1315                        (namestring (make-pathname :version :unspecific :defaults p))
1316                        #+versioned-file-system
1317                        (namestring p)))
1318                 (restart-case (multiple-value-bind (winp err) 
1319                                   (%fasload (defaulted-native-namestring file-name))
1320                                 (if (not winp) 
1321                                   (%err-disp err)))
1322                   (load-source 
1323                    ()
1324                    :test restart-test
1325                    :report (lambda (s) 
1326                              (format s "Load ~s instead of ~s" 
1327                                      (fname restart-source) (fname restart-fasl)))
1328                    (%load source-file verbose print if-does-not-exist external-format preserve-optimization-settings))
1329                   (recompile
1330                    ()
1331                    :test restart-test
1332                    :report (lambda (s)
1333                              (let ((*print-circle* NIL))
1334                                (format s
1335                                        (if (equalp
1336                                             restart-source
1337                                             (make-pathname :type (pathname-type *.lisp-pathname*)
1338                                                            :defaults restart-fasl))
1339                                          "Compile ~s and then load ~s again"
1340                                          "Compile ~s into ~s then load ~:*~s again")
1341                                        (fname restart-source) (fname restart-fasl))))
1342                    (compile-file restart-source :output-file restart-fasl)
1343                    (%load restart-fasl verbose print if-does-not-exist external-format preserve-optimization-settings))))))
1344            (t 
1345             (with-open-file (stream file-name
1346                                     :element-type 'base-char
1347                                     :external-format (if (eq external-format :default) :inferred external-format))
1348               (load-from-stream stream print)))))))
1349  file-name)
1350
1351(defun load-from-stream (stream print &aux (eof-val (list ())) val)
1352  (with-compilation-unit (:override nil) ; try this for included files
1353    (let ((env (new-lexical-environment (new-definition-environment 'eval)))
1354          ;; source note map to use with any compilations.
1355          (*nx-source-note-map*  (and *save-source-locations*
1356                                      (make-hash-table :test #'eq :shared nil)))
1357          (*loading-toplevel-location* nil))
1358      (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*)
1359      (loop
1360        (multiple-value-setq (val *loading-toplevel-location*)
1361          (read-recording-source stream
1362                                 :eofval eof-val
1363                                 :file-name *loading-file-source-file*
1364                                 :map *nx-source-note-map*
1365                                 :save-source-text (neq *save-source-locations* :no-text)))
1366        (when (eq eof-val val)
1367          (return))
1368        (when (eq print :source) (format t "~&Source: ~S~%" val))
1369        (setq val (cheap-eval-in-environment val env))
1370        (when print
1371          (format t "~&~A~S~%" (if (eq print :source) "Value: " "") val))))))
1372
1373(defun include (filename)
1374  (load
1375   (if (null *loading-files*)
1376     filename
1377     (merge-pathnames filename (directory-namestring (car *loading-files*))))))
1378
1379(%fhave '%include #'include)
1380
1381(defun delete-file (path)
1382  "Delete the specified FILE."
1383  (let* ((namestring (defaulted-native-namestring path))
1384         (err (%delete-file namestring)))
1385    (or (eql 0 err) (signal-file-error err path))))
1386
1387(defvar *known-backends* ())
1388
1389(defun fasl-file-p (pathname)
1390  (let* ((type (pathname-type pathname)))
1391    (or (and (null *known-backends*)
1392             (equal type (pathname-type *.fasl-pathname*)))
1393        (dolist (b *known-backends*)
1394          (when (equal type (pathname-type (backend-target-fasl-pathname b)))
1395            (return t)))
1396        (ignore-errors
1397          (with-open-file (f pathname
1398                             :direction :input
1399                             :element-type '(unsigned-byte 8))
1400            ;; Assume that (potential) FASL files start with #xFF00 (big-endian),
1401            ;; and that source files don't.
1402            (and (eql (read-byte f nil nil) #xff)
1403                 (eql (read-byte f nil nil) #x00)))))))
1404
1405(defun provide (module)
1406  "Adds a new module name to *MODULES* indicating that it has been loaded.
1407   Module-name is a string designator"
1408  (pushnew (string module) *modules* :test #'string=)
1409  module)
1410
1411(defparameter *loading-modules* () "Internal. Prevents circularity")
1412(defparameter *module-provider-functions* '(module-provide-search-path)
1413  "A list of functions called by REQUIRE to satisfy an unmet dependency.
1414Each function receives a module name as a single argument; if the function knows how to load that module, it should do so, add the module's name as a string to *MODULES* (perhaps by calling PROVIDE) and return non-NIL."
1415  )
1416
1417(defun module-provide-search-path (module)
1418  ;; (format *debug-io* "trying module-provide-search-path~%")
1419  (let* ((module-name (string module))
1420         (pathname (find-module-pathnames module-name)))
1421    (when pathname
1422      (if (consp pathname)
1423        (dolist (path pathname) (load path))
1424        (load pathname))
1425      (provide module))))
1426
1427(defun require (module &optional pathname)
1428  "Loads a module, unless it already has been loaded. PATHNAMES, if supplied,
1429   is a designator for a list of pathnames to be loaded if the module
1430   needs to be. If PATHNAMES is not supplied, functions from the list
1431   *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME
1432   as an argument, until one of them returns non-NIL.  User code is
1433   responsible for calling PROVIDE to indicate a successful load of the
1434   module."
1435  (let* ((str (string module))
1436         (original-modules (copy-list *modules*)))
1437    (unless (or (member str *modules* :test #'string=)
1438                (member str *loading-modules* :test #'string=))
1439      ;; The check of (and binding of) *LOADING-MODULES* is a
1440      ;; traditional defense against circularity.  (Another
1441      ;; defense is not having circularity, of course.)  The
1442      ;; effect is that if something's in the process of being
1443      ;; REQUIREd and it's REQUIREd again (transitively),
1444      ;; the inner REQUIRE is a no-op.
1445      (let ((*loading-modules* (cons str *loading-modules*)))
1446        (if pathname
1447          (dolist (path (if (atom pathname) (list pathname) pathname))
1448            (load path))
1449          (unless (some (lambda (p) (funcall p module))
1450                        *module-provider-functions*)
1451            (error "Module ~A was not provided by any function on ~S." module '*module-provider-functions*)))))
1452    (values module
1453            (set-difference *modules* original-modules))))
1454
1455(defun find-module-pathnames (module)
1456  "Returns the file or list of files making up the module"
1457  (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path)
1458        (dolist (path-cand *module-search-path* nil)
1459          (let ((mod-cand (merge-pathnames mod-path path-cand)))
1460            (if (wild-pathname-p path-cand)
1461                (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific)))
1462                       (matches (if untyped-p
1463                                    (or (directory (merge-pathnames mod-cand *.lisp-pathname*))
1464                                        (directory (merge-pathnames mod-cand *.fasl-pathname*)))
1465                                    (directory mod-cand))))
1466                  (when (and matches (null (cdr matches)))
1467                    (return (if untyped-p
1468                                (make-pathname :type nil :defaults (car matches))
1469                                (car matches)))))
1470                (when (setq path (find-load-file (merge-pathnames mod-path path-cand)))
1471                  (return path)))))))
1472
1473(defun wild-pathname-p (pathname &optional field-key)
1474  "Predicate for determining whether pathname contains any wildcards."
1475  (flet ((wild-p (name) (or (eq name :wild)
1476                            (eq name :wild-inferiors)
1477                            (and (stringp name) (%path-mem "*" name)))))
1478    (case field-key
1479      ((nil)
1480       (or (some #'wild-p (pathname-directory pathname))
1481           (wild-p (pathname-name pathname))
1482           (wild-p (pathname-type pathname))
1483           (wild-p (pathname-version pathname))))
1484      (:host nil)
1485      (:device nil)
1486      (:directory (some #'wild-p (pathname-directory pathname)))
1487      (:name (wild-p (pathname-name pathname)))
1488      (:type (wild-p (pathname-type pathname)))
1489      (:version (wild-p (pathname-version pathname)))
1490      (t (wild-pathname-p pathname
1491                          (require-type field-key 
1492                                        '(member nil :host :device 
1493                                          :directory :name :type :version)))))))
Note: See TracBrowser for help on using the repository browser.