source: trunk/source/level-1/l1-pathnames.lisp @ 11887

Last change on this file since 11887 was 11859, checked in by gb, 11 years ago

Functions that parse namestrings have called GET-SSTRING on their
string arguments so that they're sure that they're operating on a
bounded SIMPLE-STRING. Those parsing functions (hopefully all of
them) now call GET-PATHNAME-SSTRING instead. On non-Windows platforms,
this just calls GET-SSTRING and returns its results; on Windows, it
checks to see if the bounded simple-string contains backslashes and
if so, it returns a copy with the backslashes replaced with forward-slashes.

This is one way to allow pathname functions to handle Windows pathnames
that use #
as a directory separator. (The other way would be to
change a lot of ancient namestring-parsing code to handle either #
or #\/ as a directory separator, and this approach is certainly simpler.)
The extra consing should only happen if user code does something like:

(let* ((home-string (getenv "HOME")))

(if home-string

(pathname-name home-string)))

System code that deals with namestrings returned by the OS can generally
destructively change any backslashes in that namestring to forward slashes
before passing the string to pathname-parsing functions.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 30.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (c) 2001 Clozure Associates.
5;;;   This file is part of OpenMCL. 
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19
20;; L1-pathnames.lisp
21;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
22;ANSI CL logical pathnames
23
24(in-package "CCL")
25
26(defun heap-image-name ()
27  (let* ((p (%null-ptr)))
28    (declare (dynamic-extent p))
29    #-windows-target
30    (%get-cstring (%get-kernel-global-ptr 'image-name p))
31    #+windows-target
32     (nbackslash-to-forward-slash
33      (%get-cstring (%get-kernel-global-ptr 'image-name p)))))
34
35(defloadvar *heap-image-name* (heap-image-name))
36
37(defloadvar *command-line-argument-list*
38  (let* ((argv (%null-ptr))
39         (res ()))
40    (declare (dynamic-extent argv))
41    (%get-kernel-global-ptr 'argv argv)
42    (do* ((i 0 (+ i target::node-size))
43          (arg (%get-ptr argv i) (%get-ptr argv i)))
44         ((%null-ptr-p arg) (nreverse res))
45      (declare (fixnum i))
46      (push (%get-cstring arg) res))))
47
48;These are used by make-pathname
49(defun %verify-logical-component (name type)
50  (when (and name (neq name :unspecific))
51    (setq name (ensure-simple-string name))
52    (when (or (eql 0 (length name))
53              (%str-member *pathname-escape-character* name) ;; Hmm, why?
54              (%path-mem "/;" name))
55      (error "Illegal logical pathname ~A component ~S" type name)))
56  name)
57
58
59(defun verify-logical-host-name (host)
60  (or (and host
61           (%verify-logical-component host "host")
62           (%str-assoc host %logical-host-translations%)
63           host)
64      (host-error host)))
65
66(defun %logical-version-component (version)
67  (if (or (fixnump version)
68          (stringp version)
69          (memq version '(nil :wild :newest :unspecific)))
70    version
71    (require-type version '(or fixnum string (member nil :wild :newest :unspecific)))))
72
73(defun logical-pathname-translations (host)
74  "Return the (logical) host object argument's list of translations."
75  (setq host (verify-logical-host-name host))
76  (let ((translations (%str-assoc host %logical-host-translations%)))
77    (unless translations (host-error host))
78    (%cdr translations)))
79
80(defun logical-host-p (host)
81  (%str-assoc host %logical-host-translations%))
82
83(defun host-error (host) ; supposed to be a type-error
84  (signal-type-error host  '(satisfies logical-host-p) "~S is not a defined logical host"))
85
86(defun set-logical-pathname-translations (host list)
87  (setq host (%verify-logical-component  host "host"))
88  (let ((old (%str-assoc host %logical-host-translations%))
89        (new (let ((%logical-host-translations% (cons (list host) %logical-host-translations%)))
90               ;; Do this in the context when host is defined, so no errors.
91               (mapcar #'(lambda (trans)
92                           (destructuring-bind (from to &rest ignored) trans
93                             (declare (ignore ignored))
94                             (let ((from-path (parse-namestring from host))
95                                   (to-path (pathname to)))
96                               (list (require-type from-path 'logical-pathname) to-path))))
97                       list))))
98    (if old
99      (progn (%rplaca old host) (%rplacd old new))
100      (push (cons host new) %logical-host-translations%)))
101  list)
102
103(defsetf logical-pathname-translations set-logical-pathname-translations)
104
105;;; doesnt check if already there - adds at front
106(defun add-logical-pathname-translation (host translation)
107  (let ((trans (%str-assoc host  %logical-host-translations%)))
108    (if (not trans)
109      (set-logical-pathname-translations host (list translation))
110      (let ((new (destructuring-bind (from to &rest ignored) translation
111                   (declare (ignore ignored))
112                   (list (parse-namestring from host) (pathname to)))))
113        (rplacd trans (cons new (cdr trans)))
114        (cdr trans)))))
115
116(defun %component-match-p (name wild) 
117  (if (or (eq name :unspecific)(eq name :wild)(eq name :wild-inferiors)(and (stringp name) (or  (string= name "*")(string= name "**"))))
118    (setq name nil)) 
119  (if (or (eq wild :unspecific)(eq wild :wild)(eq wild :wild-inferiors)(eq wild :newest)(and (stringp wild) (or (string= wild "*")(string= wild "**"))))
120    (setq wild nil))
121  (cond ((null name) 
122         (null wild))
123        ((null wild)
124         t)
125        ((not (and (stringp name) (stringp wild)))
126         (eq name wild))
127        (t (%path-str*= name wild))))
128
129(defun translate-directory (source from to reversible &optional thost)
130  (declare (ignore thost)) ;; leftover from a mac kludge.
131  (let* ((result (translate-directory2 (cdr source)(cdr from)(cdr to) reversible))
132         (relative-p (eq (car source) :relative)))
133    (cond ((and (not relative-p)(eq result (cdr source))) (or source (list :absolute)))
134          ((and (not relative-p)(eq result (cdr to))) to)
135          (t (cons (car (or to source from)) result)))))
136
137
138
139(defun translate-directory2 (source from to reversible)
140  ; we already know it matches
141  (let (result srest match tfirst trest twild)
142    (multiple-value-setq (tfirst trest twild)
143                         (%split-ccdirectory to))
144    (when (and to (not twild))
145      (return-from translate-directory2 to))
146    (multiple-value-bind (ffirst frest fwild)
147                         (%split-ccdirectory from)
148      (setq srest (nthcdr (length ffirst) source))
149      (cond ((eq fwild '**)
150             (setq match (nth-value 1 (%pathname-match-dir1 srest frest t)))               
151             (cond ((eq twild '**)
152                    (setq result (nconc tfirst match))
153                    (setq srest (nthcdr (length match) srest)))
154                   (t (return-from translate-directory2
155                        (translate-directory2 source (nconc ffirst match frest)
156                                              to reversible)))))
157            ((eq twild '**)
158             (let ((length (length tfirst)))
159               (setq srest (nthcdr length source))
160               (setq frest (nthcdr length from))
161               (setq  match (nth-value 1 (%pathname-match-dir1 srest trest t)))
162               (cond ((null  match)
163                      (setq result tfirst))
164                     (t (setq srest (nthcdr (setq length (length match)) srest))
165                        (setq frest (nthcdr length frest))
166                        (setq result (nconc tfirst match))))))
167            (t
168             (cond ((null fwild)
169                    ; to has a wild component e.g. *abc, from is not wild
170                    ; by defintion source is also not wild
171                    ; which random source component gets plugged in here??
172                    (setq srest (nthcdr (length tfirst) source))
173                    (setq frest (nthcdr (length tfirst) source))))
174             (let ((part (translate-component
175                                (car srest) (car frest)(car trest) reversible)))
176               (if (null part)(setq result tfirst)
177                   (progn
178                     (setq part (list part))
179                     (setq result (nconc tfirst part)))))
180             (setq srest (cdr srest) frest (cdr frest) trest (cdr trest))))
181      (when trest 
182        (let ((foo (translate-directory2 srest frest trest reversible)))
183          (when foo (setq result (nconc result foo))))))
184    result))
185
186; cc stands for cdr canonical
187; ("abc" "**" "def" => ("abc") ("def")
188; ("abc" "*de") => ("abc") ("*de")
189(defun %split-ccdirectory (dir)
190  (let ((pos 0) (wildp nil)(rest dir))
191    (dolist (e dir)
192      (case e
193        (:wild (setq wildp '*))
194        (:wild-inferiors 
195         (setq wildp '**)
196         (setq rest (cdr rest)))
197        (:up nil)
198        (t 
199         (when (%path-mem "*" e)
200           (cond ((string= e "**")
201                  (setq rest (cdr rest))
202                  (setq wildp '**))
203                 ((eql 1 (length (the string e)))
204                  (setq wildp '*))
205                 (t (setq wildp t))))))
206      (when wildp (return))
207      (setq rest (cdr rest))
208      (setq pos (%i+ 1 pos)))
209    (cond ((not wildp)
210           (values dir))
211          (t (let (first)
212               (when rest (setq rest (copy-list rest)))
213               (dotimes (i pos)
214                 (declare (fixnum i))
215                 (push (car dir) first)
216                 (setq dir (cdr dir)))
217               (values (nreverse first) rest wildp))))))
218
219; could avoid calling component-match-p by checking here maybe
220; if "gazonk" "gaz*" "h*" => "honk"
221; then "gazonk" "gaz*" "*" => "onk" or is it "gazonk" (per pg 625)
222; I believe in symbolics land "gazonk" is a regular translation
223; and "onk" is a reversible translation (achieved by not doing pg 625) AHH
224; similarly is "a:" "a:**:" "**"  Nil or "a:"
225(defun translate-component (source from to &optional reversible)                   
226  (let ((orig-to to))
227    (cond 
228     ((and (consp source)(consp from)) ; source and from both logical
229      (setq source (cadr source) from (cadr from)))
230     ((or (consp source)(consp from)) ;  or neither
231      #-bccl (error "Something non-kosher in translate pathname")
232      ))
233    (when (memq from '(:wild :wild-inferiors)) (setq from "*"))
234    (when (memq source '(:wild :wild-inferiors))(setq source "*"))
235    (when (memq to '(:wild :wild-inferiors))(setq to "*"))
236    (cond ((consp to)(setq to (cadr to))))  ;??
237    (cond ((and (stringp to)(not (%path-mem "*" to)))
238           to)
239          ((and (or (not reversible)(not (stringp source))) ; <<
240                (or (null to)
241                    (and (stringp to)(or (string= to "**")(string= to "*")))))
242           source)
243          ((eq to :unspecific) to)  ; here we interpret :unspecific to mean don't want it
244          ((not (stringp source)) to)
245          (t 
246           (let ((slen (length source)) srest match spos result (f2 nil) snextpos)
247             (multiple-value-bind (tfirst trest twild)
248                                  (%split-component to)
249               (cond ((and to (not twild))(return-from translate-component to)))
250               (multiple-value-bind (ffirst frest fwild)
251                                    (%split-component from)         
252                 (cond (fwild
253                        (setq spos (if ffirst (length ffirst) 0))       ; start of source hunk
254                        (if frest (setq f2 (%split-component frest)))
255                        (setq snextpos (if f2 (%path-member f2 source spos) slen))
256                        (setq match (%substr source spos snextpos))
257                        (if frest (setq srest (%substr source snextpos slen)))
258                        (setq result (if tfirst (%str-cat tfirst match) match))
259                        (when frest 
260                          (let ((foo (translate-component srest frest trest reversible)))
261                            (when foo (setq result (%str-cat result foo))))))
262                       (t  ; to is wild, from and source are not
263                        (setq result (if tfirst (%str-cat tfirst source) source))
264                        (when trest (setq result (%str-cat result trest))))))
265               (if (consp orig-to)(progn (error "shouldnt")(list :logical result)) result) ; 7/96
266               ))))))
267
268
269(defun %path-member (small big &optional (start 0))
270  (let* ((end (length big))
271         (s-end (length small))
272         (s-start 1)
273         (c1 (%schar small 0))
274         (pstart start))
275    (if (%i> s-end end)(return-from %path-member nil))
276    (when (eql c1 *pathname-escape-character*)
277      (setq c1 (%schar small 1))
278      (setq s-start 2))     
279    (while (and (progn (if (eql (%schar big pstart) *pathname-escape-character*)
280                         (setq pstart (%i+ pstart 1)))
281                       T)
282                (%i< pstart end)
283                (neq (%schar big pstart) c1))
284      (setq pstart (%i+ pstart 1)))
285    (if (neq c1 (%schar big pstart))(return-from %path-member nil))
286    (setq start (%i+ pstart 1))
287    (while (and (progn (if (eql (%schar big start) *pathname-escape-character*)
288                         (setq start (%i+ 1 start)))
289                       (if (eql (%schar small s-start) *pathname-escape-character*)
290                         (setq s-start (%i+ 1 s-start)))
291                       T)
292                (%i< start end)
293                (%i< s-start s-end)
294                (eql (%schar big start)(%schar small s-start)))
295      (setq start (%i+ start 1) s-start (%i+ s-start 1)))
296    (cond ((= (the fixnum s-start) (the fixnum s-end))
297            pstart)
298          ((%i< start end)
299            (%path-member small big (%i+ 1 pstart)))
300          (T nil))))
301
302(defun %split-component (thing &aux pos)
303  ;"ab*cd*"  ->  "ab" "cd*" 
304  (if (or (not (typep thing 'string))(null (setq pos (%path-mem "*" thing))))
305    (values thing nil nil)
306    (let* ((len (length thing)))
307      (declare (fixnum len))
308      (values (if (%izerop pos) nil (%substr thing 0 pos))
309              (cond ((eql len (%i+ pos 1)) nil)
310                    (t 
311                     (when (eq (%schar thing (+ pos 1)) #\*)
312                       (setq pos (+ pos 1)))
313                     (cond ((eql len (%i+ pos 1)) nil)
314                           (t (%substr thing (%i+ pos 1) len)))))
315              T))))
316
317(defun translate-pathname (source from-wildname to-wildname &key reversible)
318  "Use the source pathname to translate the from-wildname's wild and
319   unspecified elements into a completed to-pathname based on the to-wildname."
320  (when (not (pathnamep source)) (setq source (pathname source)))
321  (flet ((translate-pathname-component-mismatch (component-name source from)
322           (error "~S components of source ~S and from-wildname ~S do not match" component-name source from)))
323    (let (r-host  r-directory r-name r-type r-version s-host f-host t-host t-device)
324      (setq s-host (pathname-host source))
325      (setq f-host (pathname-host from-wildname))
326      (setq t-host (pathname-host to-wildname))
327      (setq t-device (pathname-device to-wildname))
328      (if (not (%host-component-match-p s-host f-host)) (translate-pathname-component-mismatch 'pathname-host source from-wildname))
329      (setq r-host (translate-component s-host f-host t-host reversible))
330      (let ((s-dir (%std-directory-component (pathname-directory source) s-host))
331            (f-dir (%std-directory-component (pathname-directory from-wildname) f-host))
332            (t-dir (%std-directory-component (pathname-directory to-wildname) t-host)))
333        (let ((match (%pathname-match-directory s-dir f-dir)))
334          (if (not match)(translate-pathname-component-mismatch 'pathname-directory source from-wildname))
335          (setq r-directory  (translate-directory s-dir f-dir t-dir reversible t-host))))
336      (let ((s-name (pathname-name source))
337            (f-name (pathname-name from-wildname))
338            (t-name (pathname-name to-wildname)))
339        (if (not (%component-match-p s-name f-name))(translate-pathname-component-mismatch 'pathname-name  source from-wildname))       
340        (setq r-name (translate-component s-name f-name t-name reversible)))
341      (let ((s-type (pathname-type source))
342            (f-type (pathname-type from-wildname))
343            (t-type (pathname-type to-wildname)))
344        (if (not (%component-match-p s-type f-type))(translate-pathname-component-mismatch 'pathname-component source from-wildname))
345        (setq r-type (translate-component s-type f-type t-type reversible)))
346      (let ((s-version (pathname-version source))
347            (f-version (pathname-version from-wildname))
348            (t-version (pathname-version to-wildname)))
349        (if (not (%component-match-p s-version f-version)) (translate-pathname-component-mismatch 'pathname-version source from-wildname))
350        (setq r-version (translate-component s-version f-version t-version reversible))
351        ;(if (eq r-version :unspecific)(setq r-version nil))
352        )
353      (make-pathname :device t-device :host r-host :directory r-directory
354                     :name r-name :type r-type :version r-version :defaults nil)
355      )))
356
357
358
359(defvar %empty-logical-pathname% (%cons-logical-pathname nil nil nil nil nil))
360
361(defun logical-pathname-namestring-p (string)
362  (multiple-value-bind (sstr start end) (get-pathname-sstring string)
363    (let ((host (pathname-host-sstr sstr start end t)))
364      (and host (not (eq host :unspecific))))))
365
366 
367;; This extends CL in that it allows a host-less pathname, like "foo;bar;baz".
368(defun logical-pathname (thing &aux (path thing))
369  "Converts the pathspec argument to a logical-pathname and returns it."
370  (when (typep path 'stream) (setq path (%path-from-stream path)))
371  (etypecase path
372    (logical-pathname path)
373    (pathname (report-bad-arg thing 'logical-pathname))
374    (string
375     (multiple-value-bind (sstr start end) (get-sstring path)
376       ;; Prescan the host, to avoid unknown host errors.
377       (let ((host (pathname-host-sstr sstr start end t)))
378         (when (or (null host) (eq host :unspecific))
379           (report-bad-arg path '(satisfies logical-pathname-namestring-p)))
380         (let ((%logical-host-translations% (cons (list host) %logical-host-translations%)))
381           (declare (special %logical-host-translations%))
382           ;; By calling string-to-pathname with a logical pathname as default, we force
383           ;; parsing as a logical pathname.
384           (string-to-pathname sstr start end nil %empty-logical-pathname%)))))))
385
386(defun %host-component-match-p (path-host wild-host)
387  ;; Note that %component-match-p is case sensitive.  Need a
388  ;; case-insensitive version for hosts.
389  ;; In addition, host components do not support wildcards.
390  (or (eq path-host wild-host)
391      (and (stringp path-host)
392           (stringp wild-host)
393           (string-equal path-host wild-host))))
394
395(defun pathname-match-p (pathname wildname)
396  "Pathname matches the wildname template?"
397  (let ((path-host (pathname-host pathname))
398        (wild-host (pathname-host wildname)))
399    (and
400     (%host-component-match-p path-host wild-host)
401     (%component-match-p (pathname-device pathname)(pathname-device wildname))
402     (%pathname-match-directory
403      (%std-directory-component (pathname-directory pathname) path-host)
404      (%std-directory-component (pathname-directory wildname) wild-host))
405     (%component-match-p (pathname-name pathname)(pathname-name wildname))
406     (%component-match-p (pathname-type pathname)(pathname-type wildname))
407     (%component-match-p (pathname-version pathname)(pathname-version wildname)))))
408
409
410; expects canonicalized directory - how bout absolute vs. relative?
411(defun %pathname-match-directory (path wild)
412  (cond ((equal path wild) t)
413         ; Don't allow matching absolute and relative, so that can have distinct
414         ; absolute and wild translations in logical-pathname-translations for
415         ; a host, and have them match separately.
416        ((and (consp path)(consp wild)(neq (car path) (car wild)))
417         nil)  ; one absolute & one relative ??
418        ((or ;(and (null wild)
419             ;     (let ((dir (cadr path)))
420             ;       (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors))))
421             (and (null (cddr wild))
422                  (let ((dir (cadr wild)))
423                    (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors))))))
424        ((null path)
425         ;; Make missing dir match (:absolute) or (:relative) - is that right?
426         (null (cdr wild)))
427        ((null wild)
428         nil)
429        (t (%pathname-match-dir0 (cdr path)(cdr wild)))))
430
431; munch on tails path and wild
432(defun %pathname-match-dir0 (path wild)
433  (flet ((only-wild (dir)
434                    (when (null (cdr dir))
435                      (setq dir (car dir))
436                      (when (consp dir) (setq dir (cadr dir)))
437                      (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
438    (cond ((eq path wild) t)
439          ((only-wild wild)
440           t)
441          (t (let ((result t))
442               (block nil 
443                 (while (and path wild)
444                   (let ((pathstr (car path))
445                         (wildstr (car wild)))                     
446                     ; allow logical to match physical today
447                     ; because one of these days these logical things will disappear!
448                     (when (consp pathstr)(setq pathstr (cadr pathstr)))
449                     (when (consp wildstr)(setq wildstr (cadr wildstr)))
450                     (case wildstr
451                       (:wild (setq wildstr "*"))
452                       (:wild-inferiors (setq wildstr "**")))
453                     (case pathstr
454                       (:wild (setq pathstr "*"))
455                       (:wild-inferiors (setq pathstr "**")))
456                     (if (or (memq wildstr '(:up :back))(memq pathstr '(:up :back))) ;; ????? <<<<
457                       (when (neq pathstr wildstr)(setq result nil) (return-from nil))
458                       (when (not 
459                              (cond ((string= wildstr "**")
460                                     (setq result (%pathname-match-dir1 path (cdr wild)))
461                                     (return-from nil))
462                                    ((%path-str*= pathstr wildstr))))
463                         (setq result nil)
464                         (return-from nil)))
465                     (setq wild (cdr wild) path (cdr path))))
466                 (when (and (or path wild)(not (only-wild wild)))
467                   (setq result nil)))
468               result)))))
469
470
471
472; wild is stuff after a "**" - looking for what matches the **  in (path)
473(defun %pathname-match-dir1 (path wild &optional cons-result)
474  (let ((match nil) pathstr wildstr)
475    (cond ((null wild)
476           (values T (if cons-result (mapcar #'(lambda (e)
477                                            (if (consp e)(cadr e) e))
478                                        path))))
479          ((%pathname-match-dir0 path wild))   ; ie ** matches nothing
480          (t 
481           (prog nil
482             AGN
483               (setq pathstr (car path) wildstr (car wild))
484               (when (consp pathstr)(setq pathstr (cadr pathstr)))
485               (when (consp wildstr)(setq wildstr (cadr wildstr)))
486               (case wildstr
487                 (:wild (setq wildstr "*"))
488                 (:wild-inferiors (setq wildstr "**")))
489               (case pathstr
490                 (:wild (setq pathstr "*"))
491                 (:wild-inferiors (setq pathstr "**")))
492               (until (or (not (consp path))
493                          (%path-str*= pathstr wildstr))
494                 (when cons-result (push pathstr match))
495                 (setq path (cdr path))
496                 (setq pathstr (car path))
497                 (when (consp pathstr)(setq pathstr (cadr pathstr))))
498               ;; either got a match - w and path both have the thing we looked for
499               ;; or path is empty
500               (when (null path)(return nil))
501               (let ((path1 (cdr path))(wild (cdr wild)))
502                 (when (and (null path1)(null wild))
503                   (return (values t (when match (nreverse match)))))
504                 (cond ((%pathname-match-dir0 path1 wild)  ; is the rest happy too?
505                        (return (values t (nreverse match))))
506                       (t (when cons-result (push pathstr match)) ; nope, let ** eat more
507                          (setq path (cdr path))
508                          (go AGN)))))))))
509
510; three times bigger and 3 times slower - does it matter?
511(defun %path-str*= (string pattern)
512  (multiple-value-bind (string s-start s-end) (get-sstring string)
513    (multiple-value-bind (pattern p-start p-end) (get-sstring pattern)
514      (path-str-sub pattern string p-start s-start p-end s-end))))
515
516(defun path-str-sub (pattern str p-start s-start p-end s-end)
517  (declare (fixnum p-start s-start p-end s-end)
518           (type simple-base-string pattern str))
519  (declare (optimize (speed 3)(safety 0)))
520  (let ((p (%scharcode pattern p-start))
521        (esc (char-code *pathname-escape-character*)))
522    (cond 
523     ((eq p (char-code #\*))
524      ; starts with a * find what we looking for unless * is last in which case done
525      (loop ; lots of *'s same as one
526        (when (eq (%i+ 1 p-start)  p-end)
527          (return-from path-str-sub t))
528        (if (eq (%schar pattern (%i+ 1 p-start)) #\*)
529          (setq p-start (1+ p-start))
530          (return)))
531      (let* ((next* (%path-mem "*" pattern (%i+ 1 p-start)))
532             (len (- (or next* p-end) (%i+ 1 p-start))))
533        (loop
534          (when (> (+ s-start len) s-end)(return nil))
535          (let ((res (find-str-pattern pattern str (%i+ 1 p-start) s-start (or next* p-end) s-end))) 
536            (if (null res)
537              (return nil)
538              (if (null next*)
539                (if (eq res s-end)
540                  (return t))                 
541                (return (path-str-sub pattern str next* (+ s-start len) p-end s-end)))))
542          (setq s-start (1+ s-start)))))
543     (t (when (eq p esc)
544          (setq p-start (1+ p-start))
545          (setq p (%scharcode pattern p-start)))
546        (let* ((next* (%path-mem "*" pattern (if (eq p (char-code #\*))(%i+ 1 p-start) p-start)))
547               (this-s-end (if next* (+ s-start (- next* p-start)) s-end)))
548          (if (> this-s-end s-end)
549            nil
550            (if  (path-str-match-p pattern str p-start s-start (or next* p-end) this-s-end)
551              (if (null next*)
552                t                 
553                (path-str-sub pattern str next* this-s-end p-end s-end)))))))))
554
555; find match of pattern between start and end in str
556; rets one past end of pattern in str or nil
557(defun find-str-pattern (pattern str p-start s-start p-end s-end)
558  (declare (fixnum p-start s-start p-end s-end)
559           (type simple-base-string pattern str))
560  (declare (optimize (speed 3)(safety 0)))
561  (let* ((first-p (%scharcode pattern p-start))
562         (esc (char-code *pathname-escape-character*)))
563    (when (and (eq first-p esc) (not (eq (setq p-start (1+ p-start)) p-end)))
564      (setq first-p (%scharcode pattern p-start)))
565    (do* ((i s-start (1+ i))
566          (last-i (%i- s-end (%i- p-end p-start))))
567         ((> i last-i) nil)
568      (declare (fixnum i last-i))
569      (let ((s (%scharcode str i)))
570        (when (eq first-p s)
571          (do* ((j (1+ i) (1+ j))
572                (k (1+ p-start)(1+ k)))
573               ((>= k p-end) (return-from find-str-pattern j))
574            (declare (fixnum j k))
575            (let* ((p (%scharcode pattern k))
576                   (s (%scharcode str j)))
577              (when (and (eq p esc) (< (setq k (1+ k)) p-end))
578                (setq p (%scharcode pattern k)))
579              (when (not (eq p s))
580                (return)))))))))
581
582
583(defun path-str-match-p (pattern str p-start s-start p-end s-end)
584  (declare (fixnum p-start s-start p-end s-end)
585           (type simple-base-string pattern str))
586  (declare (optimize (speed 3)(safety 0)))
587  ;; does pattern match str between p-start p-end
588  (let ((esc (char-code *pathname-escape-character*)))
589    (loop     
590      (when (eq p-start p-end)
591        (return (eq s-start s-end)))
592      (when (eq s-start s-end)
593        (return nil))
594      (let ((p (%scharcode pattern p-start)))
595        (unless *case-sensitive-filesystem*
596          (setq p (%char-code-upcase p)))
597        (when (eq p esc)
598          (when (eq (setq p-start (1+ p-start)) p-end)
599            (return nil))
600          (setq p (%scharcode pattern p-start))
601          (unless *case-sensitive-filesystem*
602            (setq p (%char-code-upcase p))))
603        (let* ((q (%scharcode str s-start)))
604          (unless *case-sensitive-filesystem*
605            (setq q (%char-code-upcase q)))
606          (unless (eq p q)
607            (return nil)))
608        (setq p-start (1+ p-start))
609        (setq s-start (1+ s-start))))))
610     
611             
612
613(defun ccl-directory ()
614  (let* ((dirpath (getenv "CCL_DEFAULT_DIRECTORY")))
615    (if dirpath
616      (native-to-directory-pathname dirpath)
617      (let* ((heap-image-path (%realpath (heap-image-name))))
618        (make-pathname :directory (pathname-directory heap-image-path)
619                       :device (pathname-device heap-image-path))))))
620
621(defun user-homedir-pathname (&optional host)
622  "Return the home directory of the user as a pathname."
623  (declare (ignore host))
624  (let* ((native
625          (ignore-errors
626            (truename
627             (native-to-directory-pathname (or #+ccl-0711 (getenv "HOME")
628                                               (get-user-home-dir (getuid))))))))
629    (if (and native (eq :absolute (car (pathname-directory native))))
630      native
631      ;; Another plausible choice here is
632      ;; #p"/tmp/.hidden-directory-of-some-irc-bot-in-eastern-europe/"
633      ;; Of course, that might already be the value of $HOME.  Anyway,
634      ;; the user's home directory just contains "config files" (like
635      ;; SSH keys), and spoofing it can't hurt anything.
636      (make-pathname :directory '(:absolute) :defaults nil))))
637
638
639
640
641(defun translate-logical-pathname (pathname &key)
642  "Translate PATHNAME to a physical pathname, which is returned."
643  (setq pathname (pathname pathname))
644  (let ((host (pathname-host pathname)))
645    (cond ((eq host :unspecific) pathname)
646          ((null host) (%cons-pathname (pathname-directory pathname)
647                                       (pathname-name pathname)
648                                       (pathname-type pathname)
649                                       (pathname-version pathname)
650                                       (pathname-device pathname)))
651          (t
652           (let ((rule (assoc pathname (logical-pathname-translations host)
653                              :test #'pathname-match-p)))  ; how can they match if hosts neq??
654             (if rule
655               (translate-logical-pathname
656                (translate-pathname pathname (car rule) (cadr rule)))
657               (signal-file-error $xnotranslation pathname)))))))
658
659(defloadvar *user-homedir-pathname* (user-homedir-pathname))
660
661
662;;; Hide this from COMPILE-FILE, for obscure cross-compilation reasons
663
664(defun setup-initial-translations ()
665  (setf (logical-pathname-translations "home")
666        `(("**;*.*" ,(merge-pathnames "**/*.*" (user-homedir-pathname)))))
667
668  (setf (logical-pathname-translations "ccl")
669        `(("l1;**;*.*" "ccl:level-1;**;*.*")
670          ("l1f;**;*.*" "ccl:l1-fasls;**;*.*")
671          ("ccl;*.*" ,(merge-pathnames "*.*" (ccl-directory)))
672          ("**;*.*" ,(merge-pathnames "**/*.*" (ccl-directory))))))
673
674(setup-initial-translations)
675
676
677;;; Translate the pathname; if the directory component of the result
678;;; is relative, make it absolute (relative to the current directory.)
679(defun full-pathname (path &key (no-error t))
680  (let* ((path (handler-case (translate-logical-pathname (merge-pathnames path))
681                 (error (condition) (if no-error
682                                      (return-from full-pathname nil)
683                                      (error condition)))))
684         (dir (%pathname-directory path)))
685    (if (eq (car dir) :absolute)
686      path
687      (cons-pathname (absolute-directory-list dir)
688                       (%pathname-name path)
689                       (%pathname-type path)
690                       (pathname-host path)
691                       (pathname-version path)))))
692
693
694
695
696(defparameter *module-search-path* (list
697                                    (cons-pathname '(:absolute "bin") nil nil "ccl")
698                                    (cons-pathname '(:absolute "openmcl" "modules") nil nil "home")
699                                    (cons-pathname '(:absolute "lib") nil nil "ccl")
700                                    (cons-pathname '(:absolute "library") nil nil "ccl")
701                                    (cons-pathname '(:absolute "examples" :wild-inferiors) nil nil "ccl")
702                                    (cons-pathname '(:absolute "tools") nil nil "ccl")
703                                    (cons-pathname '(:absolute "objc-bridge") nil nil "ccl")
704                                    (cons-pathname '(:absolute "cocoa-ide") nil nil "ccl"))
705  "Holds a list of pathnames to search for the file that has same name
706   as a module somebody is looking for.")
707
Note: See TracBrowser for help on using the repository browser.