source: release/1.6/source/level-1/l1-files.lisp @ 14712

Last change on this file since 14712 was 14712, checked in by rme, 8 years ago

Merge r14662 from trunk.

Closes ticket:843.

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