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