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

Last change on this file was 16810, checked in by svspire, 3 years ago

Typo

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