2 ;;;; ---------------------------------------------------------------------------
3 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
5 ;; See https://bugs.launchpad.net/asdf/+bug/485687
8 (defpackage :uiop
/package
9 ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
10 ;; This package definition MUST NOT change unless its name too changes;
11 ;; if/when it changes, don't forget to add new functions missing from below.
12 ;; Until then, uiop/package is frozen to forever
13 ;; import and export the same exact symbols as for ASDF 2.27.
14 ;; Any other symbol must be import-from'ed and re-export'ed in a different package.
17 #:find-package
* #:find-symbol
* #:symbol-call
18 #:intern
* #:export
* #:import
* #:shadowing-import
* #:shadow
* #:make-symbol
* #:unintern
*
19 #:symbol-shadowing-p
#:home-package-p
20 #:symbol-package-name
#:standard-common-lisp-symbol-p
21 #:reify-package
#:unreify-package
#:reify-symbol
#:unreify-symbol
22 #:nuke-symbol-in-package
#:nuke-symbol
#:rehome-symbol
23 #:ensure-package-unused
#:delete-package
*
24 #:package-names
#:packages-from-names
#:fresh-package-name
#:rename-package-away
25 #:package-definition-form
#:parse-define-package-form
26 #:ensure-package
#:define-package
))
28 (in-package :uiop
/package
)
30 ;;;; General purpose package utilities
32 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
33 (defun find-package* (package-designator &optional
(error t
))
34 (let ((package (find-package package-designator
)))
37 (error (error "No package named ~S" (string package-designator
)))
39 (defun find-symbol* (name package-designator
&optional
(error t
))
40 "Find a symbol in a package of given string'ified NAME;
41 unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
42 by letting you supply a symbol or keyword for the name;
43 also works well when the package is not present.
44 If optional ERROR argument is NIL, return NIL instead of an error
45 when the symbol is not found."
47 (let ((package (find-package* package-designator error
)))
48 (when package
;; package error handled by find-package* already
49 (multiple-value-bind (symbol status
) (find-symbol (string name
) package
)
51 (status (return (values symbol status
)))
52 (error (error "There is no symbol ~S in package ~S" name
(package-name package
))))))
54 (defun symbol-call (package name
&rest args
)
55 "Call a function associated with symbol of given name in given package,
56 with given ARGS. Useful when the call is read before the package is loaded,
57 or when loading the package is optional."
58 (apply (find-symbol* name package
) args
))
59 (defun intern* (name package-designator
&optional
(error t
))
60 (intern (string name
) (find-package* package-designator error
)))
61 (defun export* (name package-designator
)
62 (let* ((package (find-package* package-designator
))
63 (symbol (intern* name package
)))
64 (export (or symbol
(list symbol
)) package
)))
65 (defun import* (symbol package-designator
)
66 (import (or symbol
(list symbol
)) (find-package* package-designator
)))
67 (defun shadowing-import* (symbol package-designator
)
68 (shadowing-import (or symbol
(list symbol
)) (find-package* package-designator
)))
69 (defun shadow* (name package-designator
)
70 (shadow (list (string name
)) (find-package* package-designator
)))
71 (defun make-symbol* (name)
73 (string (make-symbol name
))
74 (symbol (copy-symbol name
))))
75 (defun unintern* (name package-designator
&optional
(error t
))
77 (let ((package (find-package* package-designator error
)))
79 (multiple-value-bind (symbol status
) (find-symbol* name package error
)
81 (status (unintern symbol package
)
82 (return (values symbol status
)))
83 (error (error "symbol ~A not present in package ~A"
84 (string symbol
) (package-name package
))))))
86 (defun symbol-shadowing-p (symbol package
)
87 (and (member symbol
(package-shadowing-symbols package
)) t
))
88 (defun home-package-p (symbol package
)
89 (and package
(let ((sp (symbol-package symbol
)))
90 (and sp
(let ((pp (find-package* package
)))
91 (and pp
(eq sp pp
))))))))
94 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
95 (defun symbol-package-name (symbol)
96 (let ((package (symbol-package symbol
)))
97 (and package
(package-name package
))))
98 (defun standard-common-lisp-symbol-p (symbol)
99 (multiple-value-bind (sym status
) (find-symbol* symbol
:common-lisp nil
)
100 (and (eq sym symbol
) (eq status
:external
))))
101 (defun reify-package (package &optional package-context
)
102 (if (eq package package-context
) t
105 ((eql (find-package :cl
)) :cl
)
106 (package (package-name package
)))))
107 (defun unreify-package (package &optional package-context
)
110 ((eql t
) package-context
)
111 ((or symbol string
) (find-package package
))))
112 (defun reify-symbol (symbol &optional package-context
)
114 ((or keyword
(satisfies standard-common-lisp-symbol-p
)) symbol
)
115 (symbol (vector (symbol-name symbol
)
116 (reify-package (symbol-package symbol
) package-context
)))))
117 (defun unreify-symbol (symbol &optional package-context
)
121 (let* ((symbol-name (svref symbol
0))
122 (package-foo (svref symbol
1))
123 (package (unreify-package package-foo package-context
)))
124 (if package
(intern* symbol-name package
)
125 (make-symbol* symbol-name
)))))))
127 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
128 (defvar *all-package-happiness
* '())
129 (defvar *all-package-fishiness
* (list t
))
130 (defun record-fishy (info)
131 ;;(format t "~&FISHY: ~S~%" info)
132 (push info
*all-package-fishiness
*))
133 (defmacro when-package-fishiness
(&body body
)
134 `(when *all-package-fishiness
* ,@body
))
135 (defmacro note-package-fishiness
(&rest info
)
136 `(when-package-fishiness (record-fishy (list ,@info
)))))
138 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
140 (defun get-setf-function-symbol (symbol)
141 #+clisp
(let ((sym (get symbol
'system
::setf-function
)))
142 (if sym
(values sym
:setf-function
)
143 (let ((sym (get symbol
'system
::setf-expander
)))
144 (if sym
(values sym
:setf-expander
)
146 #+clozure
(gethash symbol ccl
::%setf-function-names%
))
148 (defun set-setf-function-symbol (new-setf-symbol symbol
&optional kind
)
149 #+clisp
(assert (member kind
'(:setf-function
:setf-expander
)))
150 #+clozure
(assert (eq kind t
))
153 ((null new-setf-symbol
)
154 (remprop symbol
'system
::setf-function
)
155 (remprop symbol
'system
::setf-expander
))
156 ((eq kind
:setf-function
)
157 (setf (get symbol
'system
::setf-function
) new-setf-symbol
))
158 ((eq kind
:setf-expander
)
159 (setf (get symbol
'system
::setf-expander
) new-setf-symbol
))
160 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
161 kind symbol new-setf-symbol
)))
164 (gethash symbol ccl
::%setf-function-names%
) new-setf-symbol
165 (gethash new-setf-symbol ccl
::%setf-function-name-inverses%
) symbol
))
167 (defun create-setf-function-symbol (symbol)
168 #+clisp
(system::setf-symbol symbol
)
169 #+clozure
(ccl::construct-setf-function-name symbol
))
170 (defun set-dummy-symbol (symbol reason other-symbol
)
171 (setf (get symbol
'dummy-symbol
) (cons reason other-symbol
)))
172 (defun make-dummy-symbol (symbol)
173 (let ((dummy (copy-symbol symbol
)))
174 (set-dummy-symbol dummy
'replacing symbol
)
175 (set-dummy-symbol symbol
'replaced-by dummy
)
177 (defun dummy-symbol (symbol)
178 (get symbol
'dummy-symbol
))
179 (defun get-dummy-symbol (symbol)
180 (let ((existing (dummy-symbol symbol
)))
181 (if existing
(values (cdr existing
) (car existing
))
182 (make-dummy-symbol symbol
))))
183 (defun nuke-symbol-in-package (symbol package-designator
)
184 (let ((package (find-package* package-designator
))
185 (name (symbol-name symbol
)))
186 (multiple-value-bind (sym stat
) (find-symbol name package
)
187 (when (and (member stat
'(:internal
:external
)) (eq symbol sym
))
188 (if (symbol-shadowing-p symbol package
)
189 (shadowing-import* (get-dummy-symbol symbol
) package
)
190 (unintern* symbol package
))))))
191 (defun nuke-symbol (symbol &optional
(packages (list-all-packages)))
193 (multiple-value-bind (setf-symbol kind
)
194 (get-setf-function-symbol symbol
)
195 (when kind
(nuke-symbol setf-symbol
)))
196 (loop :for p
:in packages
:do
(nuke-symbol-in-package symbol p
)))
197 (defun rehome-symbol (symbol package-designator
)
198 "Changes the home package of a symbol, also leaving it present in its old home if any"
199 (let* ((name (symbol-name symbol
))
200 (package (find-package* package-designator
))
201 (old-package (symbol-package symbol
))
202 (old-status (and old-package
(nth-value 1 (find-symbol name old-package
))))
203 (shadowing (and old-package
(symbol-shadowing-p symbol old-package
) (make-symbol name
))))
204 (multiple-value-bind (overwritten-symbol overwritten-symbol-status
) (find-symbol name package
)
205 (unless (eq package old-package
)
206 (let ((overwritten-symbol-shadowing-p
207 (and overwritten-symbol-status
208 (symbol-shadowing-p overwritten-symbol package
))))
209 (note-package-fishiness
211 (when old-package
(package-name old-package
)) old-status
(and shadowing t
)
212 (package-name package
) overwritten-symbol-status overwritten-symbol-shadowing-p
)
215 (shadowing-import* shadowing old-package
))
216 (unintern* symbol old-package
))
218 (overwritten-symbol-shadowing-p
219 (shadowing-import* symbol package
))
221 (when overwritten-symbol-status
222 (unintern* overwritten-symbol package
))
223 (import* symbol package
)))
225 (shadowing-import* symbol old-package
)
226 (import* symbol old-package
))
228 (multiple-value-bind (setf-symbol kind
)
229 (get-setf-function-symbol symbol
)
231 (let* ((setf-function (fdefinition setf-symbol
))
232 (new-setf-symbol (create-setf-function-symbol symbol
)))
233 (note-package-fishiness
235 name
(package-name package
)
236 (symbol-name setf-symbol
) (symbol-package-name setf-symbol
)
237 (symbol-name new-setf-symbol
) (symbol-package-name new-setf-symbol
))
238 (when (symbol-package setf-symbol
)
239 (unintern* setf-symbol
(symbol-package setf-symbol
)))
240 (setf (fdefinition new-setf-symbol
) setf-function
)
241 (set-setf-function-symbol new-setf-symbol symbol kind
))))
243 (multiple-value-bind (overwritten-setf foundp
)
244 (get-setf-function-symbol overwritten-symbol
)
246 (unintern overwritten-setf
)))
247 (when (eq old-status
:external
)
248 (export* symbol old-package
))
249 (when (eq overwritten-symbol-status
:external
)
250 (export* symbol package
))))
251 (values overwritten-symbol overwritten-symbol-status
))))
252 (defun ensure-package-unused (package)
253 (loop :for p
:in
(package-used-by-list package
) :do
254 (unuse-package package p
)))
255 (defun delete-package* (package &key nuke
)
256 (let ((p (find-package package
)))
258 (when nuke
(do-symbols (s p
) (when (home-package-p s p
) (nuke-symbol s
))))
259 (ensure-package-unused p
)
260 (delete-package package
))))
261 (defun package-names (package)
262 (cons (package-name package
) (package-nicknames package
)))
263 (defun packages-from-names (names)
264 (remove-duplicates (remove nil
(mapcar #'find-package names
)) :from-end t
))
265 (defun fresh-package-name (&key
(prefix :%TO-BE-DELETED
)
267 (index (random most-positive-fixnum
)))
268 (loop :for i
:from index
269 :for n
= (format nil
"~A~@[~A~D~]" prefix
(and (plusp i
) (or separator
"")) i
)
270 :thereis
(and (not (find-package n
)) n
)))
271 (defun rename-package-away (p &rest keys
&key prefix
&allow-other-keys
)
273 (apply 'fresh-package-name
274 :prefix
(or prefix
(format nil
"__~A__" (package-name p
))) keys
)))
275 (record-fishy (list :rename-away
(package-names p
) new-name
))
276 (rename-package p new-name
))))
279 ;;; Communicable representation of symbol and package information
281 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
282 (defun package-definition-form (package-designator
283 &key
(nicknamesp t
) (usep t
)
284 (shadowp t
) (shadowing-import-p t
)
285 (exportp t
) (importp t
) internp
(error t
))
286 (let* ((package (or (find-package* package-designator error
)
287 (return-from package-definition-form nil
)))
288 (name (package-name package
))
289 (nicknames (package-nicknames package
))
290 (use (mapcar #'package-name
(package-use-list package
)))
292 (shadowing-import (make-hash-table :test
'equal
))
293 (import (make-hash-table :test
'equal
))
297 (loop :for sym
:being
:the
:symbols
:in package
298 :for status
= (nth-value 1 (find-symbol* sym package
)) :do
301 ((:internal
:external
)
302 (let* ((name (symbol-name sym
))
303 (external (eq status
:external
))
304 (home (symbol-package sym
))
305 (home-name (package-name home
))
306 (imported (not (eq home package
)))
307 (shadowing (symbol-shadowing-p sym package
)))
309 ((and shadowing imported
)
310 (push name
(gethash home-name shadowing-import
)))
314 (push name
(gethash home-name import
))))
319 (t (push name intern
)))))))
320 (labels ((sort-names (names)
321 (sort (copy-list names
) #'string
<))
323 (loop :for k
:being
:the
:hash-keys
:of table
:collect k
))
324 (when-relevant (key value
)
325 (when value
(list (cons key value
))))
326 (import-options (key table
)
327 (loop :for i
:in
(sort-names (table-keys table
))
328 :collect
`(,key
,i
,@(sort-names (gethash i table
))))))
330 ,@(when-relevant :nicknames
(and nicknamesp
(sort-names nicknames
)))
331 (:use
,@(and usep
(sort-names use
)))
332 ,@(when-relevant :shadow
(and shadowp
(sort-names shadow
)))
333 ,@(import-options :shadowing-import-from
(and shadowing-import-p shadowing-import
))
334 ,@(import-options :import-from
(and importp import
))
335 ,@(when-relevant :export
(and exportp
(sort-names export
)))
336 ,@(when-relevant :intern
(and internp
(sort-names intern
)))))))))
339 ;;; ensure-package, define-package
340 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
341 (defun ensure-shadowing-import (name to-package from-package shadowed imported
)
342 (check-type name string
)
343 (check-type to-package package
)
344 (check-type from-package package
)
345 (check-type shadowed hash-table
)
346 (check-type imported hash-table
)
347 (let ((import-me (find-symbol* name from-package
)))
348 (multiple-value-bind (existing status
) (find-symbol name to-package
)
350 ((gethash name shadowed
)
351 (unless (eq import-me existing
)
352 (error "Conflicting shadowings for ~A" name
)))
354 (setf (gethash name shadowed
) t
)
355 (setf (gethash name imported
) t
)
356 (unless (or (null status
)
357 (and (member status
'(:internal
:external
))
358 (eq existing import-me
)
359 (symbol-shadowing-p existing to-package
)))
360 (note-package-fishiness
361 :shadowing-import name
362 (package-name from-package
)
363 (or (home-package-p import-me from-package
) (symbol-package-name import-me
))
364 (package-name to-package
) status
365 (and status
(or (home-package-p existing to-package
) (symbol-package-name existing
)))))
366 (shadowing-import* import-me to-package
))))))
367 (defun ensure-imported (import-me into-package
&optional from-package
)
368 (check-type import-me symbol
)
369 (check-type into-package package
)
370 (check-type from-package
(or null package
))
371 (let ((name (symbol-name import-me
)))
372 (multiple-value-bind (existing status
) (find-symbol name into-package
)
375 (import* import-me into-package
))
376 ((eq import-me existing
))
378 (let ((shadowing-p (symbol-shadowing-p existing into-package
)))
379 (note-package-fishiness
380 :ensure-imported name
381 (and from-package
(package-name from-package
))
382 (or (home-package-p import-me from-package
) (symbol-package-name import-me
))
383 (package-name into-package
)
385 (and status
(or (home-package-p existing into-package
) (symbol-package-name existing
)))
388 ((or shadowing-p
(eq status
:inherited
))
389 (shadowing-import* import-me into-package
))
391 (unintern* existing into-package
)
392 (import* import-me into-package
))))))))
394 (defun ensure-import (name to-package from-package shadowed imported
)
395 (check-type name string
)
396 (check-type to-package package
)
397 (check-type from-package package
)
398 (check-type shadowed hash-table
)
399 (check-type imported hash-table
)
400 (multiple-value-bind (import-me import-status
) (find-symbol name from-package
)
401 (when (null import-status
)
402 (note-package-fishiness
403 :import-uninterned name
(package-name from-package
) (package-name to-package
))
404 (setf import-me
(intern* name from-package
)))
405 (multiple-value-bind (existing status
) (find-symbol name to-package
)
407 ((and imported
(gethash name imported
))
408 (unless (and status
(eq import-me existing
))
409 (error "Can't import ~S from both ~S and ~S"
410 name
(package-name (symbol-package existing
)) (package-name from-package
))))
411 ((gethash name shadowed
)
412 (error "Can't both shadow ~S and import it from ~S" name
(package-name from-package
)))
414 (setf (gethash name imported
) t
))))
415 (ensure-imported import-me to-package from-package
)))
416 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited
)
417 (check-type name string
)
418 (check-type symbol symbol
)
419 (check-type to-package package
)
420 (check-type from-package package
)
421 (check-type mixp
(member nil t
)) ; no cl:boolean on Genera
422 (check-type shadowed hash-table
)
423 (check-type imported hash-table
)
424 (check-type inherited hash-table
)
425 (multiple-value-bind (existing status
) (find-symbol name to-package
)
426 (let* ((sp (symbol-package symbol
))
427 (in (gethash name inherited
))
428 (xp (and status
(symbol-package existing
))))
430 (note-package-fishiness
431 :import-uninterned name
432 (package-name from-package
) (package-name to-package
) mixp
)
433 (import* symbol from-package
)
434 (setf sp
(package-name from-package
)))
436 ((gethash name shadowed
))
438 (unless (equal sp
(first in
))
440 (ensure-shadowing-import name to-package
(second in
) shadowed imported
)
441 (error "Can't inherit ~S from ~S, it is inherited from ~S"
442 name
(package-name sp
) (package-name (first in
))))))
443 ((gethash name imported
)
444 (unless (eq symbol existing
)
445 (error "Can't inherit ~S from ~S, it is imported from ~S"
446 name
(package-name sp
) (package-name xp
))))
448 (setf (gethash name inherited
) (list sp from-package
))
449 (when (and status
(not (eq sp xp
)))
450 (let ((shadowing (symbol-shadowing-p existing to-package
)))
451 (note-package-fishiness
453 (package-name from-package
)
454 (or (home-package-p symbol from-package
) (symbol-package-name symbol
))
455 (package-name to-package
)
456 (or (home-package-p existing to-package
) (symbol-package-name existing
)))
457 (if shadowing
(ensure-shadowing-import name to-package from-package shadowed imported
)
458 (unintern* existing to-package
)))))))))
459 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited
)
460 (check-type name string
)
461 (check-type symbol symbol
)
462 (check-type to-package package
)
463 (check-type from-package package
)
464 (check-type shadowed hash-table
)
465 (check-type imported hash-table
)
466 (check-type inherited hash-table
)
467 (unless (gethash name shadowed
)
468 (multiple-value-bind (existing status
) (find-symbol name to-package
)
469 (let* ((sp (symbol-package symbol
))
470 (im (gethash name imported
))
471 (in (gethash name inherited
)))
474 (and status
(eq symbol existing
))
475 (and in
(eq sp
(first in
))))
476 (ensure-inherited name symbol to-package from-package t shadowed imported inherited
))
478 (remhash name inherited
)
479 (ensure-shadowing-import name to-package
(second in
) shadowed imported
))
481 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
482 name
(package-name from-package
)
483 (home-package-p symbol from-package
) (symbol-package-name symbol
)
484 (package-name to-package
)
485 (home-package-p existing to-package
) (symbol-package-name existing
)))
487 (ensure-inherited name symbol to-package from-package t shadowed imported inherited
)))))))
489 (defun recycle-symbol (name recycle exported
)
490 ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
491 ;; packages, and a hash-table of names (strings) of symbols scheduled to be
492 ;; EXPORTED from the package being defined. It returns two values, the
493 ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
494 ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
495 ;; re-homing of the symbol, etc.
496 (check-type name string
)
497 (check-type recycle list
)
498 (check-type exported hash-table
)
499 (when (gethash name exported
) ;; don't bother recycling private symbols
500 (let (recycled foundp
)
501 (dolist (r recycle
(values recycled foundp
))
502 (multiple-value-bind (symbol status
) (find-symbol name r
)
503 (when (and status
(home-package-p symbol r
))
506 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
507 (note-package-fishiness :recycled-duplicate name
(package-name foundp
) (package-name r
)))
509 (setf recycled symbol foundp r
)))))))))
510 (defun symbol-recycled-p (sym recycle
)
511 (check-type sym symbol
)
512 (check-type recycle list
)
513 (and (member (symbol-package sym
) recycle
) t
))
514 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported
)
515 (check-type name string
)
516 (check-type package package
)
517 (check-type intern
(member nil t
)) ; no cl:boolean on Genera
518 (check-type shadowed hash-table
)
519 (check-type imported hash-table
)
520 (check-type inherited hash-table
)
521 (unless (or (gethash name shadowed
)
522 (gethash name imported
)
523 (gethash name inherited
))
524 (multiple-value-bind (existing status
)
525 (find-symbol name package
)
526 (multiple-value-bind (recycled previous
) (recycle-symbol name recycle exported
)
528 ((and status
(eq existing recycled
) (eq previous package
)))
530 (rehome-symbol recycled package
))
531 ((and status
(eq package
(symbol-package existing
))))
534 (note-package-fishiness
536 (reify-package (symbol-package existing
) package
)
540 (intern* name package
))))))))
541 (declaim (ftype (function (t t t
&optional t
) t
) ensure-exported
))
542 (defun ensure-exported-to-user (name symbol to-package
&optional recycle
)
543 (check-type name string
)
544 (check-type symbol symbol
)
545 (check-type to-package package
)
546 (check-type recycle list
)
547 (assert (equal name
(symbol-name symbol
)))
548 (multiple-value-bind (existing status
) (find-symbol name to-package
)
549 (unless (and status
(eq symbol existing
))
552 (let ((shadowing (symbol-shadowing-p existing to-package
))
553 (recycled (symbol-recycled-p existing recycle
)))
554 (unless (and shadowing
(not recycled
))
555 (note-package-fishiness
556 :ensure-export name
(symbol-package-name symbol
)
557 (package-name to-package
)
558 (or (home-package-p existing to-package
) (symbol-package-name existing
))
560 (if (or (eq status
:inherited
) shadowing
)
561 (shadowing-import* symbol to-package
)
562 (unintern existing to-package
))
564 (when (and accessible
(eq status
:external
))
565 (ensure-exported name symbol to-package recycle
))))))
566 (defun ensure-exported (name symbol from-package
&optional recycle
)
567 (dolist (to-package (package-used-by-list from-package
))
568 (ensure-exported-to-user name symbol to-package recycle
))
569 (unless (eq from-package
(symbol-package symbol
))
570 (ensure-imported symbol from-package
))
571 (export* name from-package
))
572 (defun ensure-export (name from-package
&optional recycle
)
573 (multiple-value-bind (symbol status
) (find-symbol* name from-package
)
574 (unless (eq status
:external
)
575 (ensure-exported name symbol from-package recycle
))))
576 (defun ensure-package (name &key
577 nicknames documentation use
578 shadow shadowing-import-from
579 import-from export intern
582 #+genera
(declare (ignore documentation
))
583 (let* ((package-name (string name
))
584 (nicknames (mapcar #'string nicknames
))
585 (names (cons package-name nicknames
))
586 (previous (packages-from-names names
))
587 (discarded (cdr previous
))
589 (package (or (first previous
) (make-package package-name
:nicknames nicknames
)))
590 (recycle (packages-from-names recycle
))
591 (use (mapcar 'find-package
* use
))
592 (mix (mapcar 'find-package
* mix
))
593 (reexport (mapcar 'find-package
* reexport
))
594 (shadow (mapcar 'string shadow
))
595 (export (mapcar 'string export
))
596 (intern (mapcar 'string intern
))
597 (unintern (mapcar 'string unintern
))
598 (shadowed (make-hash-table :test
'equal
)) ; string to bool
599 (imported (make-hash-table :test
'equal
)) ; string to bool
600 (exported (make-hash-table :test
'equal
)) ; string to bool
601 ;; string to list home package and use package:
602 (inherited (make-hash-table :test
'equal
)))
603 (when-package-fishiness (record-fishy package-name
))
605 (when documentation
(setf (documentation package t
) documentation
))
606 (loop :for p
:in
(set-difference (package-use-list package
) (append mix use
))
607 :do
(note-package-fishiness :over-use name
(package-names p
))
608 (unuse-package p package
))
609 (loop :for p
:in discarded
610 :for n
= (remove-if #'(lambda (x) (member x names
:test
'equal
))
612 :do
(note-package-fishiness :nickname name
(package-names p
))
613 (cond (n (rename-package p
(first n
) (rest n
)))
614 (t (rename-package-away p
)
615 (push p to-delete
))))
616 (rename-package package package-name nicknames
)
617 (dolist (name unintern
)
618 (multiple-value-bind (existing status
) (find-symbol name package
)
620 (unless (eq status
:inherited
)
621 (note-package-fishiness
622 :unintern
(package-name package
) name
(symbol-package-name existing
) status
)
623 (unintern* name package nil
)))))
624 (dolist (name export
)
625 (setf (gethash name exported
) t
))
627 (do-external-symbols (sym p
)
628 (setf (gethash (string sym
) exported
) t
)))
629 (do-external-symbols (sym package
)
630 (let ((name (symbol-name sym
)))
631 (unless (gethash name exported
)
632 (note-package-fishiness
633 :over-export
(package-name package
) name
634 (or (home-package-p sym package
) (symbol-package-name sym
)))
635 (unexport sym package
))))
636 (dolist (name shadow
)
637 (setf (gethash name shadowed
) t
)
638 (multiple-value-bind (existing status
) (find-symbol name package
)
639 (multiple-value-bind (recycled previous
) (recycle-symbol name recycle exported
)
640 (let ((shadowing (and status
(symbol-shadowing-p existing package
))))
642 ((eq previous package
))
644 (rehome-symbol recycled package
))
645 ((or (member status
'(nil :inherited
))
646 (home-package-p existing package
)))
648 (let ((dummy (make-symbol name
)))
649 (note-package-fishiness
650 :shadow-imported
(package-name package
) name
651 (symbol-package-name existing
) status shadowing
)
652 (shadowing-import* dummy package
)
653 (import* dummy package
)))))))
654 (shadow* name package
))
655 (loop :for
(p . syms
) :in shadowing-import-from
656 :for pp
= (find-package* p
) :do
657 (dolist (sym syms
) (ensure-shadowing-import (string sym
) package pp shadowed imported
)))
659 :for pp
= (find-package* p
) :do
660 (do-external-symbols (sym pp
) (ensure-mix (symbol-name sym
) sym package pp shadowed imported inherited
)))
661 (loop :for
(p . syms
) :in import-from
662 :for pp
= (find-package p
) :do
663 (dolist (sym syms
) (ensure-import (symbol-name sym
) package pp shadowed imported
)))
664 (dolist (p (append use mix
))
665 (do-external-symbols (sym p
) (ensure-inherited (string sym
) sym package p nil shadowed imported inherited
))
666 (use-package p package
))
667 (loop :for name
:being
:the
:hash-keys
:of exported
:do
668 (ensure-symbol name package t recycle shadowed imported inherited exported
)
669 (ensure-export name package recycle
))
670 (dolist (name intern
)
671 (ensure-symbol name package t recycle shadowed imported inherited exported
))
672 (do-symbols (sym package
)
673 (ensure-symbol (symbol-name sym
) package nil recycle shadowed imported inherited exported
))
674 (map () 'delete-package
* to-delete
)
677 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
678 (defun parse-define-package-form (package clauses
)
680 :with use-p
= nil
:with recycle-p
= nil
681 :with documentation
= nil
682 :for
(kw . args
) :in clauses
683 :when
(eq kw
:nicknames
) :append args
:into nicknames
:else
684 :when
(eq kw
:documentation
)
686 (documentation (error "define-package: can't define documentation twice"))
687 ((or (atom args
) (cdr args
)) (error "define-package: bad documentation"))
688 (t (setf documentation
(car args
)))) :else
689 :when
(eq kw
:use
) :append args
:into use
:and
:do
(setf use-p t
) :else
690 :when
(eq kw
:shadow
) :append args
:into shadow
:else
691 :when
(eq kw
:shadowing-import-from
) :collect args
:into shadowing-import-from
:else
692 :when
(eq kw
:import-from
) :collect args
:into import-from
:else
693 :when
(eq kw
:export
) :append args
:into export
:else
694 :when
(eq kw
:intern
) :append args
:into intern
:else
695 :when
(eq kw
:recycle
) :append args
:into recycle
:and
:do
(setf recycle-p t
) :else
696 :when
(eq kw
:mix
) :append args
:into mix
:else
697 :when
(eq kw
:reexport
) :append args
:into reexport
:else
698 :when
(eq kw
:use-reexport
) :append args
:into use
:and
:append args
:into reexport
699 :and
:do
(setf use-p t
) :else
700 :when
(eq kw
:mix-reexport
) :append args
:into mix
:and
:append args
:into reexport
701 :and
:do
(setf use-p t
) :else
702 :when
(eq kw
:unintern
) :append args
:into unintern
:else
703 :do
(error "unrecognized define-package keyword ~S" kw
)
704 :finally
(return `(,package
705 :nicknames
,nicknames
:documentation
,documentation
706 :use
,(if use-p use
'(:common-lisp
))
707 :shadow
,shadow
:shadowing-import-from
,shadowing-import-from
708 :import-from
,import-from
:export
,export
:intern
,intern
709 :recycle
,(if recycle-p recycle
(cons package nicknames
))
710 :mix
,mix
:reexport
,reexport
:unintern
,unintern
)))))
712 (defmacro define-package
(package &rest clauses
)
713 "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
715 DEFINE-PACKAGE supports the following keywords:
716 USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
717 RECYCLE -- Recycle the package's exported symbols from the specified packages,
718 in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
719 either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
720 one of the :RECYCLE packages, the first such symbol is re-homed to the package
722 For the sake of idempotence, it is important that the package being defined
723 should appear in first position if it already exists, and even if it doesn't,
724 ahead of any package that is not going to be deleted afterwards and never
725 created again. In short, except for special cases, always make it the first
726 package on the list if the list is not empty.
727 MIX -- Takes a list of package designators. MIX behaves like
728 \(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
729 resolve conflicts in favor of the first found symbol. It may still yield
730 an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
731 REEXPORT -- Takes a list of package designators. For each package, p, in the list,
732 export symbols with the same name as those exported from p. Note that in the case
733 of shadowing, etc. the symbols with the same name may not be the same symbols.
734 UNINTERN -- Remove symbols here from PACKAGE."
736 `(apply 'ensure-package
',(parse-define-package-form package clauses
))))
738 #+(or clasp ecl gcl mkcl
) (defpackage ,package
(:use
))
739 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
741 ;;;; -------------------------------------------------------------------------
742 ;;;; Handle compatibility with multiple implementations.
743 ;;; This file is for papering over the deficiencies and peculiarities
744 ;;; of various Common Lisp implementations.
745 ;;; For implementation-specific access to the system, see os.lisp instead.
746 ;;; A few functions are defined here, but actually exported from utility;
747 ;;; from this package only common-lisp symbols are exported.
749 (uiop/package
:define-package
:uiop
/common-lisp
750 (:nicknames
:uoip
/cl
)
752 (:use-reexport
#-genera
:common-lisp
#+genera
:future-common-lisp
)
753 #+allegro
(:intern
#:*acl-warn-save
*)
754 #+cormanlisp
(:shadow
#:user-homedir-pathname
)
757 #:logical-pathname
#:translate-logical-pathname
758 #:make-broadcast-stream
#:file-namestring
)
759 #+genera
(:shadowing-import-from
:scl
#:boolean
)
760 #+genera
(:export
#:boolean
#:ensure-directories-exist
#:read-sequence
#:write-sequence
)
761 #+(or mcl cmucl
) (:shadow
#:user-homedir-pathname
))
762 (in-package :uiop
/common-lisp
)
764 #-
(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
765 (error "ASDF is not supported on your implementation. Please help us port it.")
767 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
770 ;;;; Early meta-level tweaks
772 #+(or allegro clasp clisp clozure cmucl ecl mkcl sbcl
)
773 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
774 (when (and #+allegro
(member :ics
*features
*)
775 #+(or clasp clisp cmucl ecl mkcl
) (member :unicode
*features
*)
776 #+clozure
(member :openmcl-unicode-strings
*features
*)
777 #+sbcl
(member :sb-unicode
*features
*))
778 ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
779 ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
780 (pushnew :asdf-unicode
*features
*)))
783 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
784 ;; We need to disable autoloading BEFORE any mention of package ASDF.
785 ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file
786 ;; or any previous file.
787 (setf excl
::*autoload-package-name-alist
*
788 (remove "asdf" excl
::*autoload-package-name-alist
*
789 :test
'equalp
:key
'car
))
790 (defparameter *acl-warn-save
*
791 (when (boundp 'excl
:*warn-on-nested-reader-conditionals
*)
792 excl
:*warn-on-nested-reader-conditionals
*))
793 (when (boundp 'excl
:*warn-on-nested-reader-conditionals
*)
794 (setf excl
:*warn-on-nested-reader-conditionals
* nil
))
795 (setf *print-readably
* nil
))
798 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
799 (setf *load-verbose
* nil
)
800 (defun use-ecl-byte-compiler-p () nil
))
802 #+clozure
(in-package :ccl
)
803 #+(and clozure windows-target
) ;; See http://trac.clozure.com/ccl/ticket/1117
804 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
805 (unless (fboundp 'external-process-wait
)
807 (defun external-process-wait (proc)
808 (when (and (external-process-pid proc
) (eq (external-process-%status proc
) :running
))
809 (with-interrupts-enabled
810 (wait-on-semaphore (external-process-completed proc
))))
811 (values (external-process-%exit-code proc
)
812 (external-process-%status proc
))))))
813 #+clozure
(in-package :uiop
/common-lisp
) ;; back in this package.
816 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
817 (setf ext
:*gc-verbose
* nil
)
818 (defun user-homedir-pathname ()
819 (first (ext:search-list
(cl:user-homedir-pathname
)))))
822 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
823 (deftype logical-pathname
() nil
)
824 (defun make-broadcast-stream () *error-output
*)
825 (defun translate-logical-pathname (x) x
)
826 (defun user-homedir-pathname (&optional host
)
827 (declare (ignore host
))
828 (parse-namestring (format nil
"~A\\" (cl:user-homedir-pathname
))))
829 (defun file-namestring (p)
830 (setf p
(pathname p
))
831 (format nil
"~@[~A~]~@[.~A~]" (pathname-name p
) (pathname-type p
))))
834 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
835 (setf *load-verbose
* nil
)
836 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp
*features
*) t
))
837 (unless (use-ecl-byte-compiler-p) (require :cmp
)))
840 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
841 (unless (member :ansi-cl
*features
*)
842 (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
843 (setf compiler
::*compiler-default-type
* (pathname "")
844 compiler
::*lsp-ext
* "")
845 #.
(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
848 ((or (< system
::*gcl-major-version
* 2)
849 (and (= system
::*gcl-major-version
* 2)
850 (< system
::*gcl-minor-version
* 7)))
851 '(error "GCL 2.7 or later required to use ASDF")))))
856 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
857 (unless (fboundp 'lambda
)
858 (defmacro lambda
(&whole form
&rest bvl-decls-and-body
)
859 (declare (ignore bvl-decls-and-body
)(zwei::indentation
1 1))
860 `#',(cons 'lisp
::lambda
(cdr form
))))
861 (unless (fboundp 'ensure-directories-exist
)
862 (defun ensure-directories-exist (path)
863 (fs:create-directories-recursively
(pathname path
))))
864 (unless (fboundp 'read-sequence
)
865 (defun read-sequence (sequence stream
&key
(start 0) end
)
866 (scl:send stream
:string-in nil sequence start end
)))
867 (unless (fboundp 'write-sequence
)
868 (defun write-sequence (sequence stream
&key
(start 0) end
)
869 (scl:send stream
:string-out sequence start end
)
873 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
874 ;; lispworks 3 and earlier cannot be checked for so we always assume
875 ;; at least version 4
876 (unless (member :lispworks4
*features
*)
877 (pushnew :lispworks5
+ *features
*)
878 (unless (member :lispworks5
*features
*)
879 (pushnew :lispworks6
+ *features
*)
880 (unless (member :lispworks6
*features
*)
881 (pushnew :lispworks7
+ *features
*)))))
883 #.
(or #+mcl
;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
885 "(eval-when (:load-toplevel :compile-toplevel :execute)
886 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
887 (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
888 ;; Note: ASDF may expect user-homedir-pathname to provide
889 ;; the pathname of the current user's home directory, whereas
890 ;; MCL by default provides the directory from which MCL was started.
891 ;; See http://code.google.com/p/mcl/wiki/Portability
892 (defun user-homedir-pathname ()
893 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
894 (defun probe-posix (posix-namestring)
895 \"If a file exists for the posix namestring, return the pathname\"
896 (ccl::with-cstrs ((cpath posix-namestring))
897 (ccl::rlet ((is-dir :boolean)
899 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
900 (ccl::%path-from-fsref fsref is-dir))))))"))
903 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
905 (setq clos
::*redefine-class-in-place
* t
)) ;; Make sure we have strict ANSI class redefinition semantics
909 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
910 (defmacro loop
* (&rest rest
)
911 #-genera
`(loop ,@rest
)
912 #+genera
`(lisp:loop
,@rest
))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
915 ;;;; compatfmt: avoid fancy format directives when unsupported
916 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
917 (defun frob-substrings (string substrings
&optional frob
)
918 "for each substring in SUBSTRINGS, find occurrences of it within STRING
919 that don't use parts of matched occurrences of previous strings, and
920 FROB them, that is to say, remove them if FROB is NIL,
921 replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
922 call FROB with the match and a function that emits a string in the output.
923 Return a string made of the parts not omitted or emitted by FROB."
924 (declare (optimize (speed 0) (safety #-gcl
3 #+gcl
0) (debug 3)))
925 (let ((length (length string
)) (stream nil
))
926 (labels ((emit-string (x &optional
(start 0) (end (length x
)))
928 (unless stream
(setf stream
(make-string-output-stream)))
929 (write-string x stream
:start start
:end end
)))
930 (emit-substring (start end
)
931 (when (and (zerop start
) (= end length
))
932 (return-from frob-substrings string
))
933 (emit-string string start end
))
934 (recurse (substrings start end
)
937 ((null substrings
) (emit-substring start end
))
938 (t (let* ((sub-spec (first substrings
))
939 (sub (if (consp sub-spec
) (car sub-spec
) sub-spec
))
940 (fun (if (consp sub-spec
) (cdr sub-spec
) frob
))
941 (found (search sub string
:start2 start
:end2 end
))
942 (more (rest substrings
)))
945 (recurse more start found
)
948 (string (emit-string fun
))
949 (function (funcall fun sub
#'emit-string
)))
950 (recurse substrings
(+ found
(length sub
)) end
))
952 (recurse more start end
))))))))
953 (recurse substrings
0 length
))
954 (if stream
(get-output-stream-string stream
) "")))
956 (defmacro compatfmt
(format)
958 (frob-substrings format
`("~3i~_" #+genera
,@'("~@<" "~@;" "~@:>" "~:>")))
959 #-
(or gcl genera
) format
))
960 ;;;; -------------------------------------------------------------------------
961 ;;;; General Purpose Utilities for ASDF
963 (uiop/package
:define-package
:uiop
/utility
964 (:use
:uiop
/common-lisp
:uiop
/package
)
965 ;; import and reexport a few things defined in :uiop/common-lisp
966 (:import-from
:uiop
/common-lisp
#:compatfmt
#:loop
* #:frob-substrings
967 #+(or clasp ecl
) #:use-ecl-byte-compiler-p
#+mcl
#:probe-posix
)
968 (:export
#:compatfmt
#:loop
* #:frob-substrings
#:compatfmt
969 #+(or clasp ecl
) #:use-ecl-byte-compiler-p
#+mcl
#:probe-posix
)
971 ;; magic helper to define debugging functions:
972 #:uiop-debug
#:load-uiop-debug-utility
#:*uiop-debug-utility
*
973 #:with-upgradability
;; (un)defining functions in an upgrade-friendly way
974 #:defun
* #:defgeneric
*
975 #:nest
#:if-let
;; basic flow control
976 #:parse-body
;; macro definition helper
977 #:while-collecting
#:appendf
#:length
=n-p
#:ensure-list
;; lists
978 #:remove-plist-keys
#:remove-plist-key
;; plists
979 #:emptyp
;; sequences
980 #:+non-base-chars-exist-p
+ ;; characters
981 #:+max-character-type-index
+ #:character-type-index
#:+character-types
+
982 #:base-string-p
#:strings-common-element-type
#:reduce
/strcat
#:strcat
;; strings
983 #:first-char
#:last-char
#:split-string
#:stripln
#:+cr
+ #:+lf
+ #:+crlf
+
984 #:string-prefix-p
#:string-enclosed-p
#:string-suffix-p
985 #:standard-case-symbol-name
#:find-standard-case-symbol
;; symbols
986 #:coerce-class
;; CLOS
987 #:timestamp
< #:timestamps
< #:timestamp
*< #:timestamp
<= ;; timestamps
988 #:earlier-timestamp
#:timestamps-earliest
#:earliest-timestamp
989 #:later-timestamp
#:timestamps-latest
#:latest-timestamp
#:latest-timestamp-f
990 #:list-to-hash-set
#:ensure-gethash
;; hash-table
991 #:ensure-function
#:access-at
#:access-at-count
;; functions
992 #:call-function
#:call-functions
#:register-hook-function
993 #:lexicographic
< #:lexicographic
<= ;; version
994 #:simple-style-warning
#:style-warn
;; simple style warnings
995 #:match-condition-p
#:match-any-condition-p
;; conditions
996 #:call-with-muffled-conditions
#:with-muffled-conditions
997 #:not-implemented-error
#:parameter-error
))
998 (in-package :uiop
/utility
)
1000 ;;;; Defining functions in a way compatible with hot-upgrade:
1001 ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
1002 ;; thus replacing the function without warning or error
1003 ;; even if the signature and/or generic-ness of the function has changed.
1004 ;; For a generic function, this invalidates any previous DEFMETHOD.
1005 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
1008 `(defmacro ,def
* (name formals
&rest rest
)
1009 (destructuring-bind (name &key
(supersede t
))
1010 (if (or (atom name
) (eq (car name
) 'setf
))
1011 (list name
:supersede nil
)
1013 (declare (ignorable supersede
))
1015 ;; We usually try to do it only for the functions that need it,
1016 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
1018 `((fmakunbound ',name
)))
1019 ,@(when (and #+(or clasp ecl
) (symbolp name
)) ; fails for setf functions on ecl
1020 `((declaim (notinline ,name
))))
1021 (,',def
,name
,formals
,@rest
))))))
1022 (defdef defgeneric
* defgeneric
)
1023 (defdef defun
* defun
))
1024 (defmacro with-upgradability
((&optional
) &body body
)
1025 "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
1026 to also declare the functions NOTINLINE and to accept a wrapping the function name
1027 specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
1028 is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
1029 to supersede any previous definition."
1030 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1031 ,@(loop :for form
:in body
:collect
1033 (destructuring-bind (car . cdr
) form
1035 ((defun) `(defun* ,@cdr
))
1036 ((defgeneric) `(defgeneric* ,@cdr
))
1040 ;;; Magic debugging help. See contrib/debug.lisp
1041 (with-upgradability ()
1042 (defvar *uiop-debug-utility
*
1044 (probe-file (symbol-call :asdf
:system-relative-pathname
:uiop
"contrib/debug.lisp")))
1045 (probe-file (symbol-call :uiop
/pathname
:subpathname
1046 (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")))
1047 "form that evaluates to the pathname to your favorite debugging utilities")
1049 (defmacro uiop-debug
(&rest keys
)
1050 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1051 (load-uiop-debug-utility ,@keys
)))
1053 (defun load-uiop-debug-utility (&key package utility-file
)
1054 (let* ((*package
* (if package
(find-package package
) *package
*))
1055 (keyword (read-from-string
1056 (format nil
":DBG-~:@(~A~)" (package-name *package
*)))))
1057 (unless (member keyword
*features
*)
1058 (let* ((utility-file (or utility-file
*uiop-debug-utility
*))
1059 (file (ignore-errors (probe-file (eval utility-file
)))))
1060 (if file
(load file
)
1061 (error "Failed to locate debug utility file: ~S" utility-file
)))))))
1064 (with-upgradability ()
1065 (defmacro nest
(&rest things
)
1066 "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer
1067 (reduce #'(lambda (outer inner
) `(,@outer
,inner
))
1068 things
:from-end t
))
1070 (defmacro if-let
(bindings &body
(then-form &optional else-form
)) ;; from alexandria
1071 ;; bindings can be (var form) or ((var1 form1) ...)
1072 (let* ((binding-list (if (and (consp bindings
) (symbolp (car bindings
)))
1075 (variables (mapcar #'car binding-list
)))
1077 (if (and ,@variables
)
1081 ;;; Macro definition helper
1082 (with-upgradability ()
1083 (defun parse-body (body &key documentation whole
) ;; from alexandria
1084 "Parses BODY into (values remaining-forms declarations doc-string).
1085 Documentation strings are recognized only if DOCUMENTATION is true.
1086 Syntax errors in body are signalled and WHOLE is used in the signal
1087 arguments when given."
1093 (setf current
(car body
))
1094 (when (and documentation
(stringp current
) (cdr body
))
1096 (error "Too many documentation strings in ~S." (or whole body
))
1097 (setf doc
(pop body
)))
1099 (when (and (listp current
) (eql (first current
) 'declare
))
1100 (push (pop body
) decls
)
1101 (go :declarations
)))
1102 (values body
(nreverse decls
) doc
))))
1105 ;;; List manipulation
1106 (with-upgradability ()
1107 (defmacro while-collecting
((&rest collectors
) &body body
)
1108 "COLLECTORS should be a list of names for collections. A collector
1109 defines a function that, when applied to an argument inside BODY, will
1110 add its argument to the corresponding collection. Returns multiple values,
1111 a list for each collection, in order.
1113 \(while-collecting \(foo bar\)
1114 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
1116 \(bar \(second x\)\)\)\)
1117 Returns two values: \(A B C\) and \(1 2 3\)."
1118 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x
))) collectors
))
1119 (initial-values (mapcar (constantly nil
) collectors
)))
1120 `(let ,(mapcar #'list vars initial-values
)
1121 (flet ,(mapcar #'(lambda (c v
) `(,c
(x) (push x
,v
) (values))) collectors vars
)
1123 (values ,@(mapcar #'(lambda (v) `(reverse ,v
)) vars
))))))
1125 (define-modify-macro appendf
(&rest args
)
1126 append
"Append onto list") ;; only to be used on short lists.
1128 (defun length=n-p
(x n
) ;is it that (= (length x) n) ?
1129 (check-type n
(integer 0 *))
1131 :for l
= x
:then
(cdr l
)
1132 :for i
:downfrom n
:do
1134 ((zerop i
) (return (null l
)))
1135 ((not (consp l
)) (return nil
)))))
1137 (defun ensure-list (x)
1138 (if (listp x
) x
(list x
))))
1141 ;;; Remove a key from a plist, i.e. for keyword argument cleanup
1142 (with-upgradability ()
1143 (defun remove-plist-key (key plist
)
1144 "Remove a single key from a plist"
1145 (loop* :for
(k v
) :on plist
:by
#'cddr
1147 :append
(list k v
)))
1149 (defun remove-plist-keys (keys plist
)
1150 "Remove a list of keys from a plist"
1151 (loop* :for
(k v
) :on plist
:by
#'cddr
1152 :unless
(member k keys
)
1153 :append
(list k v
))))
1157 (with-upgradability ()
1159 "Predicate that is true for an empty sequence"
1160 (or (null x
) (and (vectorp x
) (zerop (length x
))))))
1164 (with-upgradability ()
1165 ;; base-char != character on ECL, LW, SBCL, Genera.
1166 ;; NB: We assume a total order on character types.
1167 ;; If that's not true... this code will need to be updated.
1168 (defparameter +character-types
+ ;; assuming a simple hierarchy
1169 #.
(coerce (loop* :for
(type next
) :on
1170 '(;; In SCL, all characters seem to be 16-bit base-char
1171 ;; Yet somehow character fails to be a subtype of base-char
1173 ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
1174 ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
1175 #+lispworks7
+ lw
:bmp-char
1176 #+lispworks lw
:simple-char
1178 :unless
(and next
(subtypep next type
))
1179 :collect type
) 'vector
))
1180 (defparameter +max-character-type-index
+ (1- (length +character-types
+)))
1181 (defconstant +non-base-chars-exist-p
+ (plusp +max-character-type-index
+))
1182 (when +non-base-chars-exist-p
+ (pushnew :non-base-chars-exist-p
*features
*)))
1184 (with-upgradability ()
1185 (defun character-type-index (x)
1186 (declare (ignorable x
))
1187 #.
(case +max-character-type-index
+
1190 (character (if (typep x
'base-char
) 0 1))
1191 (symbol (if (subtypep x
'base-char
) 0 1))))
1193 '(or (position-if (etypecase x
1194 (character #'(lambda (type) (typep x type
)))
1195 (symbol #'(lambda (type) (subtypep x type
))))
1197 (error "Not a character or character type: ~S" x
))))))
1201 (with-upgradability ()
1202 (defun base-string-p (string)
1203 "Does the STRING only contain BASE-CHARs?"
1204 (declare (ignorable string
))
1205 (and #+non-base-chars-exist-p
(eq 'base-char
(array-element-type string
))))
1207 (defun strings-common-element-type (strings)
1208 "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
1209 (declare (ignorable strings
))
1210 #.
(if +non-base-chars-exist-p
+
1211 `(aref +character-types
+
1212 (loop :with index
= 0 :for s
:in strings
:do
1213 (flet ((consider (i)
1214 (cond ((= i
,+max-character-type-index
+) (return i
))
1215 ,@(when (> +max-character-type-index
+ 1) `(((> i index
) (setf index i
)))))))
1217 ((emptyp s
)) ;; NIL or empty string
1218 ((characterp s
) (consider (character-type-index s
)))
1219 ((stringp s
) (let ((string-type-index
1220 (character-type-index (array-element-type s
))))
1221 (unless (>= index string-type-index
)
1222 (loop :for c
:across s
:for i
= (character-type-index c
)
1224 ,@(when (> +max-character-type-index
+ 1)
1225 `((when (= i string-type-index
) (return))))))))
1226 (t (error "Invalid string designator ~S for ~S" s
'strings-common-element-type
))))
1227 :finally
(return index
)))
1230 (defun reduce/strcat
(strings &key key start end
)
1231 "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
1232 NIL is interpreted as an empty string. A character is interpreted as a string of length one."
1233 (when (or start end
) (setf strings
(subseq strings start end
)))
1234 (when key
(setf strings
(mapcar key strings
)))
1235 (loop :with output
= (make-string (loop :for s
:in strings
1236 :sum
(if (characterp s
) 1 (length s
)))
1237 :element-type
(strings-common-element-type strings
))
1239 :for input
:in strings
1240 :do
(etypecase input
1242 (character (setf (char output pos
) input
) (incf pos
))
1243 (string (replace output input
:start1 pos
) (incf pos
(length input
))))
1244 :finally
(return output
)))
1246 (defun strcat (&rest strings
)
1247 "Concatenate strings.
1248 NIL is interpreted as an empty string, a character as a string of length one."
1249 (reduce/strcat strings
))
1251 (defun first-char (s)
1252 "Return the first character of a non-empty string S, or NIL"
1253 (and (stringp s
) (plusp (length s
)) (char s
0)))
1255 (defun last-char (s)
1256 "Return the last character of a non-empty string S, or NIL"
1257 (and (stringp s
) (plusp (length s
)) (char s
(1- (length s
)))))
1259 (defun split-string (string &key max
(separator '(#\Space
#\Tab
)))
1260 "Split STRING into a list of components separated by
1261 any of the characters in the sequence SEPARATOR.
1262 If MAX is specified, then no more than max(1,MAX) components will be returned,
1263 starting the separation from the end, e.g. when called with arguments
1264 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
1266 (let ((list nil
) (words 0) (end (length string
)))
1267 (when (zerop end
) (return nil
))
1268 (flet ((separatorp (char) (find char separator
))
1269 (done () (return (cons (subseq string
0 end
) list
))))
1271 :for start
= (if (and max
(>= words
(1- max
)))
1273 (position-if #'separatorp string
:end end
:from-end t
))
1274 :do
(when (null start
) (done))
1275 (push (subseq string
(1+ start
) end
) list
)
1277 (setf end start
))))))
1279 (defun string-prefix-p (prefix string
)
1280 "Does STRING begin with PREFIX?"
1281 (let* ((x (string prefix
))
1285 (and (<= lx ly
) (string= x y
:end2 lx
))))
1287 (defun string-suffix-p (string suffix
)
1288 "Does STRING end with SUFFIX?"
1289 (let* ((x (string string
))
1293 (and (<= ly lx
) (string= x y
:start1
(- lx ly
)))))
1295 (defun string-enclosed-p (prefix string suffix
)
1296 "Does STRING begin with PREFIX and end with SUFFIX?"
1297 (and (string-prefix-p prefix string
)
1298 (string-suffix-p string suffix
)))
1300 (defvar +cr
+ (coerce #(#\Return
) 'string
))
1301 (defvar +lf
+ (coerce #(#\Linefeed
) 'string
))
1302 (defvar +crlf
+ (coerce #(#\Return
#\Linefeed
) 'string
))
1305 "Strip a string X from any ending CR, LF or CRLF.
1306 Return two values, the stripped string and the ending that was stripped,
1307 or the original value and NIL if no stripping took place.
1308 Since our STRCAT accepts NIL as empty string designator,
1309 the two results passed to STRCAT always reconstitute the original string"
1310 (check-type x string
)
1312 (flet ((c (end) (when (string-suffix-p x end
)
1313 (return (values (subseq x
0 (- (length x
) (length end
))) end
)))))
1314 (when x
(c +crlf
+) (c +lf
+) (c +cr
+) (values x nil
)))))
1316 (defun standard-case-symbol-name (name-designator)
1317 "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
1318 if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
1319 platform such as Allegro with modern syntax."
1320 (check-type name-designator
(or string symbol
))
1322 ((or (symbolp name-designator
) #+allegro
(eq excl
:*current-case-mode
* :case-sensitive-lower
))
1323 (string name-designator
))
1324 ;; Should we be doing something on CLISP?
1325 (t (string-upcase name-designator
))))
1327 (defun find-standard-case-symbol (name-designator package-designator
&optional
(error t
))
1328 "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
1329 where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
1330 If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
1331 (find-symbol* (standard-case-symbol-name name-designator
)
1332 (etypecase package-designator
1333 ((or package symbol
) package-designator
)
1334 (string (standard-case-symbol-name package-designator
)))
1337 ;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity
1338 (eval-when (#-lispworks
:compile-toplevel
:load-toplevel
:execute
)
1339 (deftype timestamp
() '(or real boolean
)))
1340 (with-upgradability ()
1341 (defun timestamp< (x y
)
1343 ((eql t
) (not (eql y t
)))
1349 (defun timestamps< (list) (loop :for y
:in list
:for x
= nil
:then y
:always
(timestamp< x y
)))
1350 (defun timestamp*< (&rest list
) (timestamps< list
))
1351 (defun timestamp<= (x y
) (not (timestamp< y x
)))
1352 (defun earlier-timestamp (x y
) (if (timestamp< x y
) x y
))
1353 (defun timestamps-earliest (list) (reduce 'earlier-timestamp list
:initial-value nil
))
1354 (defun earliest-timestamp (&rest list
) (timestamps-earliest list
))
1355 (defun later-timestamp (x y
) (if (timestamp< x y
) y x
))
1356 (defun timestamps-latest (list) (reduce 'later-timestamp list
:initial-value t
))
1357 (defun latest-timestamp (&rest list
) (timestamps-latest list
))
1358 (define-modify-macro latest-timestamp-f
(&rest timestamps
) latest-timestamp
))
1361 ;;; Function designators
1362 (with-upgradability ()
1363 (defun ensure-function (fun &key
(package :cl
))
1364 "Coerce the object FUN into a function.
1366 If FUN is a FUNCTION, return it.
1367 If the FUN is a non-sequence literal constant, return constantly that,
1368 i.e. for a boolean keyword character number or pathname.
1369 Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
1370 If FUN is a CONS, return the function that applies its CAR
1371 to the appended list of the rest of its CDR and the arguments,
1372 unless the CAR is LAMBDA, in which case the expression is evaluated.
1373 If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
1374 and EVAL that in a (FUNCTION ...) context."
1377 ((or boolean keyword character number pathname
) (constantly fun
))
1378 (hash-table #'(lambda (x) (gethash x fun
)))
1379 (symbol (fdefinition fun
))
1380 (cons (if (eq 'lambda
(car fun
))
1382 #'(lambda (&rest args
) (apply (car fun
) (append (cdr fun
) args
)))))
1383 (string (eval `(function ,(with-standard-io-syntax
1384 (let ((*package
* (find-package package
)))
1385 (read-from-string fun
))))))))
1387 (defun access-at (object at
)
1388 "Given an OBJECT and an AT specifier, list of successive accessors,
1389 call each accessor on the result of the previous calls.
1390 An accessor may be an integer, meaning a call to ELT,
1391 a keyword, meaning a call to GETF,
1392 NIL, meaning identity,
1393 a function or other symbol, meaning itself,
1394 or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
1395 As a degenerate case, the AT specifier may be an atom of a single such accessor
1397 (flet ((access (object accessor
)
1399 (function (funcall accessor object
))
1400 (integer (elt object accessor
))
1401 (keyword (getf object accessor
))
1403 (symbol (funcall accessor object
))
1404 (cons (funcall (ensure-function accessor
) object
)))))
1406 (dolist (accessor at object
)
1407 (setf object
(access object accessor
)))
1408 (access object at
))))
1410 (defun access-at-count (at)
1411 "From an AT specification, extract a COUNT of maximum number
1412 of sub-objects to read as per ACCESS-AT"
1416 ((and (consp at
) (integerp (first at
)))
1419 (defun call-function (function-spec &rest arguments
)
1420 "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
1421 with the given ARGUMENTS"
1422 (apply (ensure-function function-spec
) arguments
))
1424 (defun call-functions (function-specs)
1425 "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
1426 (map () 'call-function function-specs
))
1428 (defun register-hook-function (variable hook
&optional call-now-p
)
1429 "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
1430 When CALL-NOW-P is true, also call the function immediately."
1431 (pushnew hook
(symbol-value variable
) :test
'equal
)
1432 (when call-now-p
(call-function hook
))))
1436 (with-upgradability ()
1437 (defun coerce-class (class &key
(package :cl
) (super t
) (error 'error
))
1438 "Coerce CLASS to a class that is subclass of SUPER if specified,
1439 or invoke ERROR handler as per CALL-FUNCTION.
1441 A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
1442 -- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
1443 A string is read as a symbol while in PACKAGE, the symbol designates a class.
1445 A class object designates itself.
1446 NIL designates itself (no class).
1447 A symbol otherwise designates a class by name."
1450 (keyword (or (find-symbol* class package nil
)
1451 (find-symbol* class
*package
* nil
)))
1452 (string (symbol-call :uiop
:safe-read-from-string class
:package package
))
1455 (etypecase normalized
1456 ((or standard-class built-in-class
) normalized
)
1457 ((or null keyword
) nil
)
1458 (symbol (find-class normalized nil nil
))))
1461 ((or standard-class built-in-class
) super
)
1462 ((or null keyword
) nil
)
1463 (symbol (find-class super nil nil
)))))
1464 #+allegro
(when found
(mop:finalize-inheritance found
))
1466 (or (eq super t
) (#-cormanlisp subtypep
#+cormanlisp cl
::subclassp found super-class
))
1468 (call-function error
"Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super
)))))
1472 (with-upgradability ()
1473 (defun ensure-gethash (key table default
)
1474 "Lookup the TABLE for a KEY as by GETHASH, but if not present,
1475 call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
1476 set the corresponding entry to the result in the table.
1477 Return two values: the entry after its optional computation, and whether it was found"
1478 (multiple-value-bind (value foundp
) (gethash key table
)
1482 (setf (gethash key table
) (call-function default
)))
1485 (defun list-to-hash-set (list &aux
(h (make-hash-table :test
'equal
)))
1486 "Convert a LIST into hash-table that has the same elements when viewed as a set,
1487 up to the given equality TEST"
1488 (dolist (x list h
) (setf (gethash x h
) t
))))
1491 ;;; Lexicographic comparison of lists of numbers
1492 (with-upgradability ()
1493 (defun lexicographic< (element< x y
)
1494 "Lexicographically compare two lists of using the function element< to compare elements.
1495 element< is a strict total order; the resulting order on X and Y will also be strict."
1496 (cond ((null y
) nil
)
1498 ((funcall element
< (car x
) (car y
)) t
)
1499 ((funcall element
< (car y
) (car x
)) nil
)
1500 (t (lexicographic< element
< (cdr x
) (cdr y
)))))
1502 (defun lexicographic<= (element< x y
)
1503 "Lexicographically compare two lists of using the function element< to compare elements.
1504 element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
1505 (not (lexicographic< element
< y x
))))
1508 ;;; Simple style warnings
1509 (with-upgradability ()
1510 (define-condition simple-style-warning
1511 #+sbcl
(sb-int:simple-style-warning
) #-sbcl
(simple-condition style-warning
)
1514 (defun style-warn (datum &rest arguments
)
1516 (string (warn (make-condition 'simple-style-warning
:format-control datum
:format-arguments arguments
)))
1517 (symbol (assert (subtypep datum
'style-warning
)) (apply 'warn datum arguments
))
1518 (style-warning (apply 'warn datum arguments
)))))
1521 ;;; Condition control
1523 (with-upgradability ()
1524 (defparameter +simple-condition-format-control-slot
+
1525 #+abcl
'system
::format-control
1526 #+allegro
'excl
::format-control
1527 #+(or clasp ecl mkcl
) 'si
::format-control
1528 #+clisp
'system
::$format-control
1529 #+clozure
'ccl
::format-control
1530 #+(or cmucl scl
) 'conditions
::format-control
1531 #+(or gcl lispworks
) 'conditions
::format-string
1532 #+sbcl
'sb-kernel
:format-control
1533 #-
(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl
) nil
1534 "Name of the slot for FORMAT-CONTROL in simple-condition")
1536 (defun match-condition-p (x condition
)
1537 "Compare received CONDITION to some pattern X:
1538 a symbol naming a condition class,
1539 a simple vector of length 2, arguments to find-symbol* with result as above,
1540 or a string describing the format-control of a simple-condition."
1542 (symbol (typep condition x
))
1544 (ignore-errors (typep condition
(find-symbol* (svref x
0) (svref x
1) nil
))))
1545 (function (funcall x condition
))
1546 (string (and (typep condition
'simple-condition
)
1547 ;; On SBCL, it's always set and the check triggers a warning
1548 #+(or allegro clozure cmucl lispworks scl
)
1549 (slot-boundp condition
+simple-condition-format-control-slot
+)
1550 (ignore-errors (equal (simple-condition-format-control condition
) x
))))))
1552 (defun match-any-condition-p (condition conditions
)
1553 "match CONDITION against any of the patterns of CONDITIONS supplied"
1554 (loop :for x
:in conditions
:thereis
(match-condition-p x condition
)))
1556 (defun call-with-muffled-conditions (thunk conditions
)
1557 "calls the THUNK in a context where the CONDITIONS are muffled"
1558 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions
)
1559 (muffle-warning c
)))))
1562 (defmacro with-muffled-conditions
((conditions) &body body
)
1563 "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
1564 `(call-with-muffled-conditions #'(lambda () ,@body
) ,conditions
)))
1568 (with-upgradability ()
1569 (define-condition not-implemented-error
(error)
1570 ((functionality :initarg
:functionality
)
1571 (format-control :initarg
:format-control
)
1572 (format-arguments :initarg
:format-arguments
))
1573 (:report
(lambda (condition stream
)
1574 (format stream
"Not (currently) implemented on ~A: ~S~@[ ~?~]"
1575 (nth-value 1 (symbol-call :uiop
:implementation-type
))
1576 (slot-value condition
'functionality
)
1577 (slot-value condition
'format-control
)
1578 (slot-value condition
'format-arguments
)))))
1580 (defun not-implemented-error (functionality &optional format-control
&rest format-arguments
)
1581 "Signal an error because some FUNCTIONALITY is not implemented in the current version
1582 of the software on the current platform; it may or may not be implemented in different combinations
1583 of version of the software and of the underlying platform. Optionally, report a formatted error
1585 (error 'not-implemented-error
1586 :functionality functionality
1587 :format-control format-control
1588 :format-arguments format-arguments
))
1590 (define-condition parameter-error
(error)
1591 ((functionality :initarg
:functionality
)
1592 (format-control :initarg
:format-control
)
1593 (format-arguments :initarg
:format-arguments
))
1594 (:report
(lambda (condition stream
)
1595 (apply 'format stream
1596 (slot-value condition
'format-control
)
1597 (slot-value condition
'functionality
)
1598 (slot-value condition
'format-arguments
)))))
1600 ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
1601 ;; the format-control. If you want it to not appear in first position in actual message, use
1602 ;; ~* and ~:* to adjust parameter order.
1603 (defun parameter-error (format-control functionality
&rest format-arguments
)
1604 "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
1605 platform does not accept a given parameter or combination of parameters. Report a formatted error
1606 message, that takes the functionality as its first argument (that can be skipped with ~*)."
1607 (error 'parameter-error
1608 :functionality functionality
1609 :format-control format-control
1610 :format-arguments format-arguments
)))
1612 (uiop/package
:define-package
:uiop
/version
1613 (:recycle
:uiop
/version
:uiop
/utility
:asdf
)
1614 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
)
1617 #:parse-version
#:unparse-version
#:version
< #:version
<= ;; version support, moved from uiop/utility
1619 #:deprecated-function-condition
#:deprecated-function-name
;; deprecation control
1620 #:deprecated-function-style-warning
#:deprecated-function-warning
1621 #:deprecated-function-error
#:deprecated-function-should-be-deleted
1622 #:version-deprecation
#:with-deprecation
))
1623 (in-package :uiop
/version
)
1625 (with-upgradability ()
1626 (defparameter *uiop-version
* "3.3.1")
1628 (defun unparse-version (version-list)
1629 "From a parsed version (a list of natural numbers), compute the version string"
1630 (format nil
"~{~D~^.~}" version-list
))
1632 (defun parse-version (version-string &optional on-error
)
1633 "Parse a VERSION-STRING as a series of natural numbers separated by dots.
1634 Return a (non-null) list of integers if the string is valid;
1635 otherwise return NIL.
1637 When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
1638 with format arguments explaining why the version is invalid.
1639 ON-ERROR is also called if the version is not canonical
1640 in that it doesn't print back to itself, but the list is returned anyway."
1642 (unless (stringp version-string
)
1643 (call-function on-error
"~S: ~S is not a string" 'parse-version version-string
)
1645 (unless (loop :for prev
= nil
:then c
:for c
:across version-string
1646 :always
(or (digit-char-p c
)
1647 (and (eql c
#\.
) prev
(not (eql prev
#\.
))))
1648 :finally
(return (and c
(digit-char-p c
))))
1649 (call-function on-error
"~S: ~S doesn't follow asdf version numbering convention"
1650 'parse-version version-string
)
1652 (let* ((version-list
1653 (mapcar #'parse-integer
(split-string version-string
:separator
".")))
1654 (normalized-version (unparse-version version-list
)))
1655 (unless (equal version-string normalized-version
)
1656 (call-function on-error
"~S: ~S contains leading zeros" 'parse-version version-string
))
1659 (defun next-version (version)
1660 "When VERSION is not nil, it is a string, then parse it as a version, compute the next version
1661 and return it as a string."
1663 (let ((version-list (parse-version version
)))
1664 (incf (car (last version-list
)))
1665 (unparse-version version-list
))))
1667 (defun version< (version1 version2
)
1668 "Given two version strings, return T if the second is strictly newer"
1669 (let ((v1 (parse-version version1 nil
))
1670 (v2 (parse-version version2 nil
)))
1671 (lexicographic< '< v1 v2
)))
1673 (defun version<= (version1 version2
)
1674 "Given two version strings, return T if the second is newer or the same"
1675 (not (version< version2 version1
))))
1678 (with-upgradability ()
1679 (define-condition deprecated-function-condition
(condition)
1680 ((name :initarg
:name
:reader deprecated-function-name
)))
1681 (define-condition deprecated-function-style-warning
(deprecated-function-condition style-warning
) ())
1682 (define-condition deprecated-function-warning
(deprecated-function-condition warning
) ())
1683 (define-condition deprecated-function-error
(deprecated-function-condition error
) ())
1684 (define-condition deprecated-function-should-be-deleted
(deprecated-function-condition error
) ())
1686 (defun deprecated-function-condition-kind (type)
1688 ((deprecated-function-style-warning) :style-warning
)
1689 ((deprecated-function-warning) :warning
)
1690 ((deprecated-function-error) :error
)
1691 ((deprecated-function-should-be-deleted) :delete
)))
1693 (defmethod print-object ((c deprecated-function-condition
) stream
)
1694 (let ((name (deprecated-function-name c
)))
1697 (let ((fmt "#.(make-condition '~S :name ~S)")
1698 (args (list (type-of c
) name
)))
1700 (apply 'format stream fmt args
)
1701 (error "Can't print ~?" fmt args
))))
1703 (print-unreadable-object (c stream
:type t
) (format stream
":name ~S" name
)))
1705 (let ((*package
* (find-package :cl
))
1708 (if (eq type
'deprecated-function-should-be-deleted
)
1709 "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete"
1710 "~A: Using deprecated function ~S -- please update your code to use a newer API.~
1711 ~@[~%The docstring for this function says:~%~A~%~]")
1712 type name
(when (symbolp name
) (documentation name
'function
))))))))
1714 (defun notify-deprecated-function (status name
)
1717 ((:style-warning
) (style-warn 'deprecated-function-style-warning
:name name
))
1718 ((:warning
) (warn 'deprecated-function-warning
:name name
))
1719 ((:error
) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error
:name name
))))
1721 (defun version-deprecation (version &key
(style-warning nil
)
1722 (warning (next-version style-warning
))
1723 (error (next-version warning
))
1724 (delete (next-version error
)))
1725 "Given a VERSION string, and the starting versions for notifying the programmer of
1726 various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION
1727 that is the highest level that has a declared version older than the specified version.
1728 Each start version for a level of deprecation can be specified by a keyword argument, or
1729 if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation."
1731 ((and delete
(version<= delete version
)) :delete
)
1732 ((and error
(version<= error version
)) :error
)
1733 ((and warning
(version<= warning version
)) :warning
)
1734 ((and style-warning
(version<= style-warning version
)) :style-warning
)))
1736 (defmacro with-deprecation
((level) &body definitions
)
1737 "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the
1738 DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function
1739 when it is compiled or called.
1741 Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet),
1742 :STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used),
1743 :ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while
1746 Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD
1747 from instrumentation by enclosing it in a PROGN."
1748 (let ((level (eval level
)))
1749 (check-type level
(member nil
:style-warning
:warning
:error
:delete
))
1750 (when (eq level
:delete
)
1751 (error 'deprecated-function-should-be-deleted
:name
1753 (remove-if-not #'(lambda (x) (member x
'(defun defmethod)))
1754 definitions
:key
'first
))))
1755 (labels ((instrument (name head body whole
)
1758 (intern (format nil
"*~A-~A-~A-~A*"
1759 :deprecated-function level name
:notified-p
))))
1760 (multiple-value-bind (remaining-forms declarations doc-string
)
1761 (parse-body body
:documentation t
:whole whole
)
1763 (defparameter ,notifiedp nil
)
1764 ;; tell some implementations to use the compiler-macro
1765 (declaim (inline ,name
))
1766 (define-compiler-macro ,name
(&whole form
&rest args
)
1767 (declare (ignore args
))
1768 (notify-deprecated-function ,level
',name
)
1770 (,@head
,@(when doc-string
(list doc-string
)) ,@declarations
1773 (notify-deprecated-function ,level
',name
))
1774 ,@remaining-forms
))))
1776 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1777 (setf (compiler-macro-function ',name
) nil
))
1778 (declaim (notinline ,name
))
1781 ,@(loop :for form
:in definitions
:collect
1783 ((and (consp form
) (eq (car form
) 'defun
))
1784 (instrument (second form
) (subseq form
0 3) (subseq form
3) form
))
1785 ((and (consp form
) (eq (car form
) 'defmethod
))
1786 (let ((body-start (if (listp (third form
)) 3 4)))
1787 (instrument (second form
)
1788 (subseq form
0 body-start
)
1789 (subseq form body-start
)
1793 ;;;; ---------------------------------------------------------------------------
1794 ;;;; Access to the Operating System
1796 (uiop/package
:define-package
:uiop
/os
1797 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
)
1799 #:featurep
#:os-unix-p
#:os-macosx-p
#:os-windows-p
#:os-genera-p
#:detect-os
;; features
1801 #:getenv
#:getenvp
;; environment variables
1802 #:implementation-identifier
;; implementation identifier
1803 #:implementation-type
#:*implementation-type
*
1804 #:operating-system
#:architecture
#:lisp-version-string
1805 #:hostname
#:getcwd
#:chdir
1806 ;; Windows shortcut support
1807 #:read-null-terminated-string
#:read-little-endian
1808 #:parse-file-location-info
#:parse-windows-shortcut
))
1809 (in-package :uiop
/os
)
1812 (with-upgradability ()
1813 (defun featurep (x &optional
(*features
* *features
*))
1814 "Checks whether a feature expression X is true with respect to the *FEATURES* set,
1815 as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
1816 we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
1817 your reader will not have magically used the KEYWORD package, so you need specify
1818 keywords explicitly."
1820 ((atom x
) (and (member x
*features
*) t
))
1821 ((eq :not
(car x
)) (assert (null (cddr x
))) (not (featurep (cadr x
))))
1822 ((eq :or
(car x
)) (some #'featurep
(cdr x
)))
1823 ((eq :and
(car x
)) (every #'featurep
(cdr x
)))
1824 (t (parameter-error "~S: malformed feature specification ~S" 'featurep x
))))
1826 ;; Starting with UIOP 3.1.5, these are runtime tests.
1827 ;; You may bind *features* with a copy of what your target system offers to test its properties.
1828 (defun os-macosx-p ()
1829 "Is the underlying operating system MacOS X?"
1830 ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
1831 ;; in fact the former implies the latter.
1832 (featurep '(:or
:darwin
(:and
:allegro
:macosx
) (:and
:clisp
:macos
))))
1835 "Is the underlying operating system some Unix variant?"
1836 (or (featurep '(:or
:unix
:cygwin
)) (os-macosx-p)))
1838 (defun os-windows-p ()
1839 "Is the underlying operating system Microsoft Windows?"
1840 (and (not (os-unix-p)) (featurep '(:or
:win32
:windows
:mswindows
:mingw32
:mingw64
))))
1842 (defun os-genera-p ()
1843 "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
1846 (defun os-oldmac-p ()
1847 "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
1850 (defun os-haiku-p ()
1851 "Is the underlying operating system Haiku?"
1855 "Detects the current operating system. Only needs be run at compile-time,
1856 except on ABCL where it might change between FASL compilation and runtime."
1858 :for
(feature . detect
) :in
'((:os-unix . os-unix-p
) (:os-macosx . os-macosx-p
)
1859 (:os-windows . os-windows-p
)
1860 (:genera . os-genera-p
) (:os-oldmac . os-oldmac-p
)
1861 (:haiku . os-haiku-p
))
1862 :when
(and (or (not o
) (eq feature
:os-macosx
)) (funcall detect
))
1863 :do
(setf o feature
) (pushnew feature
*features
*)
1864 :else
:do
(setf *features
* (remove feature
*features
*))
1866 (return (or o
(error "Congratulations for trying ASDF on an operating system~%~
1867 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
1869 (defmacro os-cond
(&rest clauses
)
1870 #+abcl
`(cond ,@clauses
)
1871 #-abcl
(loop* :for
(test . body
) :in clauses
:when
(eval test
) :return
`(progn ,@body
)))
1875 ;;;; Environment variables: getting them, and parsing them.
1876 (with-upgradability ()
1878 "Query the environment, as in C getenv.
1879 Beware: may return empty string if a variable is present but empty;
1880 use getenvp to return NIL in such a case."
1881 (declare (ignorable x
))
1882 #+(or abcl clasp clisp ecl xcl
) (ext:getenv x
)
1883 #+allegro
(sys:getenv x
)
1884 #+clozure
(ccl:getenv x
)
1885 #+cmucl
(unix:unix-getenv x
)
1886 #+scl
(cdr (assoc x ext
:*environment-list
* :test
#'string
=))
1888 (let* ((buffer (ct:malloc
1))
1889 (cname (ct:lisp-string-to-c-string x
))
1890 (needed-size (win:getenvironmentvariable cname buffer
0))
1891 (buffer1 (ct:malloc
(1+ needed-size
))))
1892 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size
))
1894 (ct:c-string-to-lisp-string buffer1
))
1897 #+gcl
(system:getenv x
)
1899 #+lispworks
(lispworks:environment-variable x
)
1900 #+mcl
(ccl:with-cstrs
((name x
))
1901 (let ((value (_getenv name
)))
1902 (unless (ccl:%null-ptr-p value
)
1903 (ccl:%get-cstring value
))))
1904 #+mkcl
(#.
(or (find-symbol* 'getenv
:si nil
) (find-symbol* 'getenv
:mk-ext nil
)) x
)
1905 #+sbcl
(sb-ext:posix-getenv x
)
1906 #-
(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
1907 (not-implemented-error 'getenv
))
1909 (defsetf getenv
(x) (val)
1910 "Set an environment variable."
1911 (declare (ignorable x val
))
1912 #+allegro
`(setf (sys:getenv
,x
) ,val
)
1913 #+clisp
`(system::setenv
,x
,val
)
1914 #+clozure
`(ccl:setenv
,x
,val
)
1915 #+cmucl
`(unix:unix-setenv
,x
,val
1)
1916 #+ecl
`(ext:setenv
,x
,val
)
1917 #+lispworks
`(hcl:setenv
,x
,val
)
1918 #+mkcl
`(mkcl:setenv
,x
,val
)
1919 #+sbcl
`(progn (require :sb-posix
) (symbol-call :sb-posix
:setenv
,x
,val
1))
1920 #-
(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl
)
1921 '(not-implemented-error '(setf getenv
)))
1924 "Predicate that is true if the named variable is present in the libc environment,
1925 then returning the non-empty string value of the variable"
1926 (let ((g (getenv x
))) (and (not (emptyp g
)) g
))))
1929 ;;;; implementation-identifier
1931 ;; produce a string to identify current implementation.
1932 ;; Initially stolen from SLIME's SWANK, completely rewritten since.
1933 ;; We're back to runtime checking, for the sake of e.g. ABCL.
1935 (with-upgradability ()
1936 (defun first-feature (feature-sets)
1937 "A helper for various feature detection functions"
1938 (dolist (x feature-sets
)
1939 (multiple-value-bind (short long feature-expr
)
1941 (values (first x
) (second x
) (cons :or
(rest x
)))
1943 (when (featurep feature-expr
)
1944 (return (values short long
))))))
1946 (defun implementation-type ()
1947 "The type of Lisp implementation used, as a short UIOP-standardized keyword"
1949 '(:abcl
(:acl
:allegro
) (:ccl
:clozure
) :clisp
(:corman
:cormanlisp
)
1950 (:cmu
:cmucl
:cmu
) :clasp
:ecl
:gcl
1951 (:lwpe
:lispworks-personal-edition
) (:lw
:lispworks
)
1952 :mcl
:mkcl
:sbcl
:scl
(:smbx
:symbolics
) :xcl
)))
1954 (defvar *implementation-type
* (implementation-type)
1955 "The type of Lisp implementation used, as a short UIOP-standardized keyword")
1957 (defun operating-system ()
1958 "The operating system of the current host"
1961 (:win
:windows
:mswindows
:win32
:mingw32
) ;; try cygwin first!
1962 (:linux
:linux
:linux-target
) ;; for GCL at least, must appear before :bsd
1963 (:macosx
:macosx
:darwin
:darwin-target
:apple
) ; also before :bsd
1964 (:solaris
:solaris
:sunos
)
1965 (:bsd
:bsd
:freebsd
:netbsd
:openbsd
:dragonfly
)
1969 (defun architecture ()
1970 "The CPU architecture of the current host"
1972 '((:x64
:x86-64
:x86_64
:x8664-target
:amd64
(:and
:word-size
=64 :pc386
))
1973 (:x86
:x86
:i386
:i486
:i586
:i686
:pentium3
:pentium4
:pc386
:iapx386
:x8632-target
)
1974 (:ppc64
:ppc64
:ppc64-target
) (:ppc32
:ppc32
:ppc32-target
:ppc
:powerpc
)
1975 :hppa64
:hppa
:sparc64
(:sparc32
:sparc32
:sparc
)
1976 :mipsel
:mipseb
:mips
:alpha
(:arm
:arm
:arm-target
) :imach
1977 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
1978 ;; we may have to segregate the code still by architecture.
1979 (:java
:java
:java-1.4
:java-1.5
:java-1.6
:java-1.7
))))
1982 (defun ccl-fasl-version ()
1983 ;; the fasl version is target-dependent from CCL 1.8 on.
1984 (or (let ((s 'ccl
::target-fasl-version
))
1985 (and (fboundp s
) (funcall s
)))
1986 (and (boundp 'ccl
::fasl-version
)
1987 (symbol-value 'ccl
::fasl-version
))
1988 (error "Can't determine fasl version.")))
1990 (defun lisp-version-string ()
1991 "return a string that identifies the current Lisp implementation version"
1992 (let ((s (lisp-implementation-version)))
1993 (car ; as opposed to OR, this idiom prevents some unreachable code warning
1996 (format nil
"~A~@[~A~]~@[~A~]~@[~A~]"
1997 excl
::*common-lisp-version-number
*
1998 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
1999 (and (eq excl
:*current-case-mode
* :case-sensitive-lower
) "M")
2000 ;; Note if not using International ACL
2001 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
2002 (excl:ics-target-case
(:-ics
"8"))
2003 (and (member :smp
*features
*) "S"))
2004 #+armedbear
(format nil
"~a-fasl~a" s system
::*fasl-version
*)
2006 (subseq s
0 (position #\space s
)) ; strip build information (date, etc.)
2008 (format nil
"~d.~d-f~d" ; shorten for windows
2009 ccl
::*openmcl-major-version
*
2010 ccl
::*openmcl-minor-version
*
2011 (logand (ccl-fasl-version) #xFF
))
2012 #+cmucl
(substitute #\-
#\
/ s
)
2013 #+scl
(format nil
"~A~A" s
2014 ;; ANSI upper case vs lower case.
2015 (ecase ext
:*case-mode
* (:upper
"") (:lower
"l")))
2016 #+ecl
(format nil
"~A~@[-~A~]" s
2017 (let ((vcs-id (ext:lisp-implementation-vcs-id
)))
2018 (unless (equal vcs-id
"UNKNOWN")
2019 (subseq vcs-id
0 (min (length vcs-id
) 8)))))
2020 #+gcl
(subseq s
(1+ (position #\space s
)))
2022 (multiple-value-bind (major minor
) (sct:get-system-version
"System")
2023 (format nil
"~D.~D" major minor
))
2024 #+mcl
(subseq s
8) ; strip the leading "Version "
2025 ;; seems like there should be a shorter way to do this, like ACALL.
2027 (let ((fname (find-symbol* '#:git-describe-this-mkcl
:mkcl nil
)))
2028 (when (and fname
(fboundp fname
))
2033 (defun implementation-identifier ()
2034 "Return a string that identifies the ABI of the current implementation,
2035 suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
2037 #\_
#'(lambda (x) (find x
" /:;&^\\|?<>(){}[]$#`'\""))
2038 (format nil
"~(~a~@{~@[-~a~]~}~)"
2039 (or (implementation-type) (lisp-implementation-type))
2040 (lisp-version-string)
2041 (or (operating-system) (software-type))
2042 (or (architecture) (machine-type))))))
2045 ;;;; Other system information
2047 (with-upgradability ()
2049 "return the hostname of the current host"
2050 #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl
) (machine-instance)
2051 #+cormanlisp
"localhost" ;; is there a better way? Does it matter?
2052 #+allegro
(symbol-call :excl.osi
:gethostname
)
2053 #+clisp
(first (split-string (machine-instance) :separator
" "))
2054 #+gcl
(system:gethostname
)))
2057 ;;; Current directory
2058 (with-upgradability ()
2061 (defun parse-unix-namestring* (unix-namestring)
2062 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
2063 (multiple-value-bind (host device directory name type version
)
2064 (lisp::parse-unix-namestring unix-namestring
0 (length unix-namestring
))
2065 (make-pathname :host
(or host lisp
::*unix-host
*) :device device
2066 :directory directory
:name name
:type type
:version version
)))
2069 "Get the current working directory as per POSIX getcwd(3), as a pathname object"
2070 (or #+(or abcl genera xcl
) (truename *default-pathname-defaults
*) ;; d-p-d is canonical!
2071 #+allegro
(excl::current-directory
)
2072 #+clisp
(ext:default-directory
)
2073 #+clozure
(ccl:current-directory
)
2074 #+(or cmucl scl
) (#+cmucl parse-unix-namestring
* #+scl lisp
::parse-unix-namestring
2075 (strcat (nth-value 1 (unix:unix-current-directory
)) "/"))
2076 #+cormanlisp
(pathname (pl::get-current-directory
)) ;; Q: what type does it return?
2077 #+(or clasp ecl
) (ext:getcwd
)
2078 #+gcl
(let ((*default-pathname-defaults
* #p
"")) (truename #p
""))
2079 #+lispworks
(hcl:get-working-directory
)
2080 #+mkcl
(mk-ext:getcwd
)
2081 #+sbcl
(sb-ext:parse-native-namestring
(sb-unix:posix-getcwd
/))
2082 #+xcl
(extensions:current-directory
)
2083 (not-implemented-error 'getcwd
)))
2086 "Change current directory, as per POSIX chdir(2), to a given pathname object"
2087 (if-let (x (pathname x
))
2088 #+(or abcl genera xcl
) (setf *default-pathname-defaults
* (truename x
)) ;; d-p-d is canonical!
2089 #+allegro
(excl:chdir x
)
2091 #+clozure
(setf (ccl:current-directory
) x
)
2092 #+(or cmucl scl
) (unix:unix-chdir
(ext:unix-namestring x
))
2093 #+cormanlisp
(unless (zerop (win32::_chdir
(namestring x
)))
2094 (error "Could not set current directory to ~A" x
))
2095 #+(or clasp ecl
) (ext:chdir x
)
2096 #+gcl
(system:chdir x
)
2097 #+lispworks
(hcl:change-directory x
)
2098 #+mkcl
(mk-ext:chdir x
)
2099 #+sbcl
(progn (require :sb-posix
) (symbol-call :sb-posix
:chdir
(sb-ext:native-namestring x
)))
2100 #-
(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl
)
2101 (not-implemented-error 'chdir
))))
2104 ;;;; -----------------------------------------------------------------
2105 ;;;; Windows shortcut support. Based on:
2107 ;;;; Jesse Hager: The Windows Shortcut File Format.
2108 ;;;; http://www.wotsit.org/list.asp?fc=13
2110 #-
(or clisp genera
) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
2111 (with-upgradability ()
2112 (defparameter *link-initial-dword
* 76)
2113 (defparameter *link-guid
* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
2115 (defun read-null-terminated-string (s)
2116 "Read a null-terminated string from an octet stream S"
2117 ;; note: doesn't play well with UNICODE
2118 (with-output-to-string (out)
2119 (loop :for code
= (read-byte s
)
2121 :do
(write-char (code-char code
) out
))))
2123 (defun read-little-endian (s &optional
(bytes 4))
2124 "Read a number in little-endian format from an byte (octet) stream S,
2125 the number having BYTES octets (defaulting to 4)."
2126 (loop :for i
:from
0 :below bytes
2127 :sum
(ash (read-byte s
) (* 8 i
))))
2129 (defun parse-file-location-info (s)
2130 "helper to parse-windows-shortcut"
2131 (let ((start (file-position s
))
2132 (total-length (read-little-endian s
))
2133 (end-of-header (read-little-endian s
))
2134 (fli-flags (read-little-endian s
))
2135 (local-volume-offset (read-little-endian s
))
2136 (local-offset (read-little-endian s
))
2137 (network-volume-offset (read-little-endian s
))
2138 (remaining-offset (read-little-endian s
)))
2139 (declare (ignore total-length end-of-header local-volume-offset
))
2140 (unless (zerop fli-flags
)
2142 ((logbitp 0 fli-flags
)
2143 (file-position s
(+ start local-offset
)))
2144 ((logbitp 1 fli-flags
)
2145 (file-position s
(+ start
2146 network-volume-offset
2148 (strcat (read-null-terminated-string s
)
2150 (file-position s
(+ start remaining-offset
))
2151 (read-null-terminated-string s
))))))
2153 (defun parse-windows-shortcut (pathname)
2154 "From a .lnk windows shortcut, extract the pathname linked to"
2155 ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
2156 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
2158 (when (and (= (read-little-endian s
) *link-initial-dword
*)
2159 (let ((header (make-array (length *link-guid
*))))
2160 (read-sequence header s
)
2161 (equalp header
*link-guid
*)))
2162 (let ((flags (read-little-endian s
)))
2163 (file-position s
76) ;skip rest of header
2164 (when (logbitp 0 flags
)
2165 ;; skip shell item id list
2166 (let ((length (read-little-endian s
2)))
2167 (file-position s
(+ length
(file-position s
)))))
2170 (parse-file-location-info s
))
2172 (when (logbitp 2 flags
)
2173 ;; skip description string
2174 (let ((length (read-little-endian s
2)))
2175 (file-position s
(+ length
(file-position s
)))))
2176 (when (logbitp 3 flags
)
2177 ;; finally, our pathname
2178 (let* ((length (read-little-endian s
2))
2179 (buffer (make-array length
)))
2180 (read-sequence buffer s
)
2181 (map 'string
#'code-char buffer
)))))))
2183 (declare (ignore c
))
2187 ;;;; -------------------------------------------------------------------------
2188 ;;;; Portability layer around Common Lisp pathnames
2189 ;; This layer allows for portable manipulation of pathname objects themselves,
2190 ;; which all is necessary prior to any access the filesystem or environment.
2192 (uiop/package
:define-package
:uiop
/pathname
2193 (:nicknames
:asdf
/pathname
) ;; deprecated. Used by ceramic
2194 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/os
)
2196 ;; Making and merging pathnames, portably
2197 #:normalize-pathname-directory-component
#:denormalize-pathname-directory-component
2198 #:merge-pathname-directory-components
#:*unspecific-pathname-type
* #:make-pathname
*
2199 #:make-pathname-component-logical
#:make-pathname-logical
2201 #:nil-pathname
#:*nil-pathname
* #:with-pathname-defaults
2203 #:pathname-equal
#:logical-pathname-p
#:physical-pathname-p
#:physicalize-pathname
2204 #:absolute-pathname-p
#:relative-pathname-p
#:hidden-pathname-p
#:file-pathname-p
2206 #:pathname-directory-pathname
#:pathname-parent-directory-pathname
2207 #:directory-pathname-p
#:ensure-directory-pathname
2208 ;; Parsing filenames
2209 #:split-name-type
#:parse-unix-namestring
#:unix-namestring
2210 #:split-unix-namestring-directory-components
2211 ;; Absolute and relative pathnames
2212 #:subpathname
#:subpathname
*
2213 #:ensure-absolute-pathname
2214 #:pathname-root
#:pathname-host-pathname
2215 #:subpathp
#:enough-pathname
#:with-enough-pathname
#:call-with-enough-pathname
2216 ;; Checking constraints
2217 #:ensure-pathname
;; implemented in filesystem.lisp to accommodate for existence constraints
2218 ;; Wildcard pathnames
2219 #:*wild
* #:*wild-file
* #:*wild-file-for-directory
* #:*wild-directory
*
2220 #:*wild-inferiors
* #:*wild-path
* #:wilden
2221 ;; Translate a pathname
2222 #:relativize-directory-component
#:relativize-pathname-directory
2223 #:directory-separator-for-host
#:directorize-pathname-host-device
2224 #:translate-pathname
*
2225 #:*output-translation-function
*))
2226 (in-package :uiop
/pathname
)
2228 ;;; Normalizing pathnames across implementations
2230 (with-upgradability ()
2231 (defun normalize-pathname-directory-component (directory)
2232 "Convert the DIRECTORY component from a format usable by the underlying
2233 implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
2234 that is a list and not a string."
2236 #-
(or cmucl sbcl scl
) ;; these implementations already normalize directory components.
2237 ((stringp directory
) `(:absolute
,directory
))
2238 ((or (null directory
)
2239 (and (consp directory
) (member (first directory
) '(:absolute
:relative
))))
2243 (cons :relative directory
))
2245 (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>")
2246 'normalize-pathname-directory-component directory
))))
2248 (defun denormalize-pathname-directory-component (directory-component)
2249 "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
2250 by the underlying implementation's MAKE-PATHNAME and other primitives"
2251 directory-component
)
2253 (defun merge-pathname-directory-components (specified defaults
)
2254 "Helper for MERGE-PATHNAMES* that handles directory components"
2255 (let ((directory (normalize-pathname-directory-component specified
)))
2256 (ecase (first directory
)
2258 (:absolute specified
)
2260 (let ((defdir (normalize-pathname-directory-component defaults
))
2261 (reldir (cdr directory
)))
2265 ((not (eq :back
(first reldir
)))
2266 (append defdir reldir
))
2268 (loop :with defabs
= (first defdir
)
2269 :with defrev
= (reverse (rest defdir
))
2270 :while
(and (eq :back
(car reldir
))
2271 (or (and (eq :absolute defabs
) (null defrev
))
2272 (stringp (car defrev
))))
2273 :do
(pop reldir
) (pop defrev
)
2274 :finally
(return (cons defabs
(append (reverse defrev
) reldir
)))))))))))
2276 ;; Giving :unspecific as :type argument to make-pathname is not portable.
2277 ;; See CLHS make-pathname and 19.2.2.2.3.
2278 ;; This will be :unspecific if supported, or NIL if not.
2279 (defparameter *unspecific-pathname-type
*
2280 #+(or abcl allegro clozure cmucl genera lispworks sbcl scl
) :unspecific
2281 #+(or clasp clisp ecl mkcl gcl xcl
#|These haven
't been tested
:|
# cormanlisp mcl
) nil
2282 "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
2284 (defun make-pathname* (&rest keys
&key directory host device name type version defaults
2285 #+scl
&allow-other-keys
)
2286 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
2287 tries hard to make a pathname that will actually behave as documented,
2288 despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME."
2289 (declare (ignore host device directory name type version defaults
))
2290 (apply 'make-pathname keys
))
2292 (defun make-pathname-component-logical (x)
2293 "Make a pathname component suitable for use in a logical-pathname"
2295 ((eql :unspecific
) nil
)
2296 #+clisp
(string (string-upcase x
))
2297 #+clisp
(cons (mapcar 'make-pathname-component-logical x
))
2300 (defun make-pathname-logical (pathname host
)
2301 "Take a PATHNAME's directory, name, type and version components,
2302 and make a new pathname with corresponding components and specified logical HOST"
2305 :directory
(make-pathname-component-logical (pathname-directory pathname
))
2306 :name
(make-pathname-component-logical (pathname-name pathname
))
2307 :type
(make-pathname-component-logical (pathname-type pathname
))
2308 :version
(make-pathname-component-logical (pathname-version pathname
))))
2310 (defun merge-pathnames* (specified &optional
(defaults *default-pathname-defaults
*))
2311 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
2312 if the SPECIFIED pathname does not have an absolute directory,
2313 then the HOST and DEVICE both come from the DEFAULTS, whereas
2314 if the SPECIFIED pathname does have an absolute directory,
2315 then the HOST and DEVICE both come from the SPECIFIED pathname.
2316 This is what users want on a modern Unix or Windows operating system,
2317 unlike the MERGE-PATHNAMES behavior.
2318 Also, if either argument is NIL, then the other argument is returned unmodified;
2319 this is unlike MERGE-PATHNAMES which always merges with a pathname,
2320 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
2321 (when (null specified
) (return-from merge-pathnames
* defaults
))
2322 (when (null defaults
) (return-from merge-pathnames
* specified
))
2324 (ext:resolve-pathname specified defaults
)
2326 (let* ((specified (pathname specified
))
2327 (defaults (pathname defaults
))
2328 (directory (normalize-pathname-directory-component (pathname-directory specified
)))
2329 (name (or (pathname-name specified
) (pathname-name defaults
)))
2330 (type (or (pathname-type specified
) (pathname-type defaults
)))
2331 (version (or (pathname-version specified
) (pathname-version defaults
))))
2332 (labels ((unspecific-handler (p)
2333 (if (typep p
'logical-pathname
) #'make-pathname-component-logical
#'identity
)))
2334 (multiple-value-bind (host device directory unspecific-handler
)
2335 (ecase (first directory
)
2337 (values (pathname-host specified
)
2338 (pathname-device specified
)
2340 (unspecific-handler specified
)))
2342 (values (pathname-host defaults
)
2343 (pathname-device defaults
)
2344 (merge-pathname-directory-components directory
(pathname-directory defaults
))
2345 (unspecific-handler defaults
))))
2346 (make-pathname :host host
:device device
:directory directory
2347 :name
(funcall unspecific-handler name
)
2348 :type
(funcall unspecific-handler type
)
2349 :version
(funcall unspecific-handler version
))))))
2351 (defun logical-pathname-p (x)
2352 "is X a logical-pathname?"
2353 (typep x
'logical-pathname
))
2355 (defun physical-pathname-p (x)
2356 "is X a pathname that is not a logical-pathname?"
2357 (and (pathnamep x
) (not (logical-pathname-p x
))))
2359 (defun physicalize-pathname (x)
2360 "if X is a logical pathname, use translate-logical-pathname on it."
2361 ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP
2362 (let ((p (when x
(pathname x
))))
2363 (if (logical-pathname-p p
) (translate-logical-pathname p
) p
)))
2365 (defun nil-pathname (&optional
(defaults *default-pathname-defaults
*))
2366 "A pathname that is as neutral as possible for use as defaults
2367 when merging, making or parsing pathnames"
2368 ;; 19.2.2.2.1 says a NIL host can mean a default host;
2369 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
2370 ;; strings and lists of strings or :unspecific
2371 ;; But CMUCL decides to die on NIL.
2372 ;; MCL has issues with make-pathname, nil and defaulting
2373 (declare (ignorable defaults
))
2374 #.
`(make-pathname :directory nil
:name nil
:type nil
:version nil
2375 :device
(or #+(and mkcl os-unix
) :unspecific
)
2376 :host
(or #+cmucl lisp
::*unix-host
* #+(and mkcl os-unix
) "localhost")
2377 #+scl
,@'(:scheme nil
:scheme-specific-part nil
2378 :username nil
:password nil
:parameters nil
:query nil
:fragment nil
)
2379 ;; the default shouldn't matter, but we really want something physical
2380 #-mcl
,@'(:defaults defaults
)))
2382 (defvar *nil-pathname
* (nil-pathname (physicalize-pathname (user-homedir-pathname)))
2383 "A pathname that is as neutral as possible for use as defaults
2384 when merging, making or parsing pathnames")
2386 (defmacro with-pathname-defaults
((&optional defaults
) &body body
)
2387 "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
2388 where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
2389 on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
2390 `(let ((*default-pathname-defaults
*
2392 #-
(or abcl genera xcl
) '*nil-pathname
*
2393 #+(or abcl genera xcl
) '*default-pathname-defaults
*)))
2397 ;;; Some pathname predicates
2398 (with-upgradability ()
2399 (defun pathname-equal (p1 p2
)
2400 "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?"
2401 (when (stringp p1
) (setf p1
(pathname p1
)))
2402 (when (stringp p2
) (setf p2
(pathname p2
)))
2403 (flet ((normalize-component (x)
2404 (unless (member x
'(nil :unspecific
:newest
(:relative
)) :test
'equal
)
2406 (macrolet ((=?
(&rest accessors
)
2408 (reduce 'list
(cons 'normalize-component accessors
)
2409 :initial-value x
:from-end t
)))
2410 `(equal ,(frob 'p1
) ,(frob 'p2
)))))
2411 (or (and (null p1
) (null p2
))
2412 (and (pathnamep p1
) (pathnamep p2
)
2413 (and (=? pathname-host
)
2414 #-
(and mkcl os-unix
) (=? pathname-device
)
2415 (=? normalize-pathname-directory-component pathname-directory
)
2418 #-mkcl
(=? pathname-version
)))))))
2420 (defun absolute-pathname-p (pathspec)
2421 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2422 possessing an :ABSOLUTE directory component, return the (parsed) pathname.
2423 Otherwise return NIL"
2425 (typep pathspec
'(or null pathname string
))
2426 (let ((pathname (pathname pathspec
)))
2427 (and (eq :absolute
(car (normalize-pathname-directory-component
2428 (pathname-directory pathname
))))
2431 (defun relative-pathname-p (pathspec)
2432 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2433 possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
2434 Otherwise return NIL"
2436 (typep pathspec
'(or null pathname string
))
2437 (let* ((pathname (pathname pathspec
))
2438 (directory (normalize-pathname-directory-component
2439 (pathname-directory pathname
))))
2440 (when (or (null directory
) (eq :relative
(car directory
)))
2443 (defun hidden-pathname-p (pathname)
2444 "Return a boolean that is true if the pathname is hidden as per Unix style,
2445 i.e. its name starts with a dot."
2446 (and pathname
(equal (first-char (pathname-name pathname
)) #\.
)))
2448 (defun file-pathname-p (pathname)
2449 "Does PATHNAME represent a file, i.e. has a non-null NAME component?
2451 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
2453 Note that this does _not_ check to see that PATHNAME points to an
2454 actually-existing file.
2456 Returns the (parsed) PATHNAME when true"
2458 (let ((pathname (pathname pathname
)))
2459 (unless (and (member (pathname-name pathname
) '(nil :unspecific
"") :test
'equal
)
2460 (member (pathname-type pathname
) '(nil :unspecific
"") :test
'equal
))
2464 ;;; Directory pathnames
2465 (with-upgradability ()
2466 (defun pathname-directory-pathname (pathname)
2467 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2468 and NIL NAME, TYPE and VERSION components"
2470 (make-pathname :name nil
:type nil
:version nil
:defaults pathname
)))
2472 (defun pathname-parent-directory-pathname (pathname)
2473 "Returns a new pathname that corresponds to the parent of the current pathname's directory,
2474 i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2475 Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2477 (make-pathname :name nil
:type nil
:version nil
2478 :directory
(merge-pathname-directory-components
2479 '(:relative
:back
) (pathname-directory pathname
))
2480 :defaults pathname
)))
2482 (defun directory-pathname-p (pathname)
2483 "Does PATHNAME represent a directory?
2485 A directory-pathname is a pathname _without_ a filename. The three
2486 ways that the filename components can be missing are for it to be NIL,
2487 :UNSPECIFIC or the empty string.
2489 Note that this does _not_ check to see that PATHNAME points to an
2490 actually-existing directory."
2492 ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
2493 ;; because it rejects apparently legal pathnames as
2494 ;; ill-formed. [2014/02/10:rpg]
2495 (let ((pathname (pathname pathname
)))
2496 (flet ((check-one (x)
2497 (member x
'(nil :unspecific
) :test
'equal
)))
2498 (and (not (wild-pathname-p pathname
))
2499 (check-one (pathname-name pathname
))
2500 (check-one (pathname-type pathname
))
2503 (defun ensure-directory-pathname (pathspec &optional
(on-error 'error
))
2504 "Converts the non-wild pathname designator PATHSPEC to directory form."
2507 (ensure-directory-pathname (pathname pathspec
)))
2508 ((not (pathnamep pathspec
))
2509 (call-function on-error
(compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec
))
2510 ((wild-pathname-p pathspec
)
2511 (call-function on-error
(compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec
))
2512 ((directory-pathname-p pathspec
)
2516 (make-pathname :directory
(append (or (normalize-pathname-directory-component
2517 (pathname-directory pathspec
))
2519 (list (file-namestring pathspec
)))
2520 :name nil
:type nil
:version nil
:defaults pathspec
)
2521 (error (c) (call-function on-error
(compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c
)))))))
2524 ;;; Parsing filenames
2525 (with-upgradability ()
2526 (declaim (ftype function ensure-pathname
)) ; forward reference
2528 (defun split-unix-namestring-directory-components
2529 (unix-namestring &key ensure-directory dot-dot
)
2530 "Splits the path string UNIX-NAMESTRING, returning four values:
2531 A flag that is either :absolute or :relative, indicating
2532 how the rest of the values are to be interpreted.
2533 A directory path --- a list of strings and keywords, suitable for
2534 use with MAKE-PATHNAME when prepended with the flag value.
2535 Directory components with an empty name or the name . are removed.
2536 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2537 A last-component, either a file-namestring including type extension,
2538 or NIL in the case of a directory pathname.
2539 A flag that is true iff the unix-style-pathname was just
2540 a file-namestring without / path specification.
2541 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2542 the third return value will be NIL, and final component of the namestring
2543 will be treated as part of the directory path.
2545 An empty string is thus read as meaning a pathname object with all fields nil.
2547 Note that colon characters #\: will NOT be interpreted as host specification.
2548 Absolute pathnames are only appropriate on Unix-style systems.
2550 The intention of this function is to support structured component names,
2551 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
2552 (check-type unix-namestring string
)
2553 (check-type dot-dot
(member nil
:back
:up
))
2554 (if (and (not (find #\
/ unix-namestring
)) (not ensure-directory
)
2555 (plusp (length unix-namestring
)))
2556 (values :relative
() unix-namestring t
)
2557 (let* ((components (split-string unix-namestring
:separator
"/"))
2558 (last-comp (car (last components
))))
2559 (multiple-value-bind (relative components
)
2560 (if (equal (first components
) "")
2561 (if (equal (first-char unix-namestring
) #\
/)
2562 (values :absolute
(cdr components
))
2563 (values :relative nil
))
2564 (values :relative components
))
2565 (setf components
(remove-if #'(lambda (x) (member x
'("" ".") :test
#'equal
))
2567 (setf components
(substitute (or dot-dot
:back
) ".." components
:test
#'equal
))
2569 ((equal last-comp
"")
2570 (values relative components nil nil
)) ; "" already removed from components
2572 (values relative components nil nil
))
2574 (values relative
(butlast components
) last-comp nil
)))))))
2576 (defun split-name-type (filename)
2577 "Split a filename into two values NAME and TYPE that are returned.
2578 We assume filename has no directory component.
2579 The last . if any separates name and type from from type,
2580 except that if there is only one . and it is in first position,
2581 the whole filename is the NAME with an empty type.
2582 NAME is always a string.
2583 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
2584 (check-type filename string
)
2585 (assert (plusp (length filename
)))
2586 (destructuring-bind (name &optional
(type *unspecific-pathname-type
*))
2587 (split-string filename
:max
2 :separator
".")
2589 (values filename
*unspecific-pathname-type
*)
2590 (values name type
))))
2592 (defun parse-unix-namestring (name &rest keys
&key type defaults dot-dot ensure-directory
2594 "Coerce NAME into a PATHNAME using standard Unix syntax.
2596 Unix syntax is used whether or not the underlying system is Unix;
2597 on such non-Unix systems it is reliably usable only for relative pathnames.
2598 This function is especially useful to manipulate relative pathnames portably,
2599 where it is of crucial to possess a portable pathname syntax independent of the underlying OS.
2600 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2602 When given a PATHNAME object, just return it untouched.
2603 When given NIL, just return NIL.
2604 When given a non-null SYMBOL, first downcase its name and treat it as a string.
2605 When given a STRING, portably decompose it into a pathname as below.
2607 #\\/ separates directory components.
2609 The last #\\/-separated substring is interpreted as follows:
2610 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2611 the string is made the last directory component, and NAME and TYPE are NIL.
2612 if the string is empty, it's the empty pathname with all slots NIL.
2613 2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
2614 are separated by SPLIT-NAME-TYPE.
2615 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2617 Directory components with an empty name or the name \".\" are removed.
2618 Any directory named \"..\" is read as DOT-DOT,
2619 which must be one of :BACK or :UP and defaults to :BACK.
2621 HOST, DEVICE and VERSION components are taken from DEFAULTS,
2622 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL.
2623 No host or device can be specified in the string itself,
2624 which makes it unsuitable for absolute pathnames outside Unix.
2626 For relative pathnames, these components (and hence the defaults) won't matter
2627 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2628 which is an important reason to always use MERGE-PATHNAMES*.
2630 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2631 with those keys, removing TYPE DEFAULTS and DOT-DOT.
2632 When you're manipulating pathnames that are supposed to make sense portably
2633 even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2634 to throw an error if the pathname is absolute"
2636 (check-type type
(or null string
(eql :directory
)))
2637 (when ensure-directory
2638 (setf type
:directory
))
2640 ((or null pathname
) (return name
))
2642 (setf name
(string-downcase name
)))
2644 (multiple-value-bind (relative path filename file-only
)
2645 (split-unix-namestring-directory-components
2646 name
:dot-dot dot-dot
:ensure-directory
(eq type
:directory
))
2647 (multiple-value-bind (name type
)
2649 ((or (eq type
:directory
) (null filename
))
2652 (values filename type
))
2654 (split-name-type filename
)))
2655 (apply 'ensure-pathname
2657 :directory
(unless file-only
(cons relative path
))
2658 :name name
:type type
2659 :defaults
(or #-mcl defaults
*nil-pathname
*))
2660 (remove-plist-keys '(:type
:dot-dot
:defaults
) keys
))))))
2662 (defun unix-namestring (pathname)
2663 "Given a non-wild PATHNAME, return a Unix-style namestring for it.
2664 If the PATHNAME is NIL or a STRING, return it unchanged.
2666 This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2667 This is a portable solution for representing relative pathnames,
2668 But unless you are running on a Unix system, it is not a general solution
2669 to representing native pathnames.
2671 An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2672 or if it is a PATHNAME but some of its components are not recognized."
2674 ((or null string
) pathname
)
2676 (with-output-to-string (s)
2677 (flet ((err () (parameter-error "~S: invalid unix-namestring ~S"
2678 'unix-namestring pathname
)))
2679 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname
)))
2680 (name (pathname-name pathname
))
2681 (name (and (not (eq name
:unspecific
)) name
))
2682 (type (pathname-type pathname
))
2683 (type (and (not (eq type
:unspecific
)) type
)))
2685 ((member dir
'(nil :unspecific
)))
2686 ((eq dir
'(:relative
)) (princ "./" s
))
2688 (destructuring-bind (relabs &rest dirs
) dir
2689 (or (member relabs
'(:relative
:absolute
)) (err))
2690 (when (eq relabs
:absolute
) (princ #\
/ s
))
2691 (loop :for x
:in dirs
:do
2693 ((member x
'(:back
:up
)) (princ "../" s
))
2694 ((equal x
"") (err))
2695 ;;((member x '("." "..") :test 'equal) (err))
2696 ((stringp x
) (format s
"~A/" x
))
2701 (unless (and (stringp name
) (or (null type
) (stringp type
))) (err))
2702 (format s
"~A~@[.~A~]" name type
))
2704 (or (null type
) (err)))))))))))
2706 ;;; Absolute and relative pathnames
2707 (with-upgradability ()
2708 (defun subpathname (pathname subpath
&key type
)
2709 "This function takes a PATHNAME and a SUBPATH and a TYPE.
2710 If SUBPATH is already a PATHNAME object (not namestring),
2711 and is an absolute pathname at that, it is returned unchanged;
2712 otherwise, SUBPATH is turned into a relative pathname with given TYPE
2713 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2714 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2715 (or (and (pathnamep subpath
) (absolute-pathname-p subpath
))
2716 (merge-pathnames* (parse-unix-namestring subpath
:type type
:want-relative t
)
2717 (pathname-directory-pathname pathname
))))
2719 (defun subpathname* (pathname subpath
&key type
)
2720 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2722 (subpathname (ensure-directory-pathname pathname
) subpath
:type type
)))
2724 (defun pathname-root (pathname)
2725 "return the root directory for the host and device of given PATHNAME"
2726 (make-pathname :directory
'(:absolute
)
2727 :name nil
:type nil
:version nil
2728 :defaults pathname
;; host device, and on scl, *some*
2729 ;; scheme-specific parts: port username password, not others:
2730 .
#.
(or #+scl
'(:parameters nil
:query nil
:fragment nil
))))
2732 (defun pathname-host-pathname (pathname)
2733 "return a pathname with the same host as given PATHNAME, and all other fields NIL"
2734 (make-pathname :directory nil
2735 :name nil
:type nil
:version nil
:device nil
2736 :defaults pathname
;; host device, and on scl, *some*
2737 ;; scheme-specific parts: port username password, not others:
2738 .
#.
(or #+scl
'(:parameters nil
:query nil
:fragment nil
))))
2740 (defun ensure-absolute-pathname (path &optional defaults
(on-error 'error
))
2741 "Given a pathname designator PATH, return an absolute pathname as specified by PATH
2742 considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
2743 with a format control-string and other arguments as arguments"
2745 ((absolute-pathname-p path
))
2746 ((stringp path
) (ensure-absolute-pathname (pathname path
) defaults on-error
))
2747 ((not (pathnamep path
)) (call-function on-error
"not a valid pathname designator ~S" path
))
2748 ((let ((default-pathname (if (pathnamep defaults
) defaults
(call-function defaults
))))
2749 (or (if (absolute-pathname-p default-pathname
)
2750 (absolute-pathname-p (merge-pathnames* path default-pathname
))
2751 (call-function on-error
"Default pathname ~S is not an absolute pathname"
2753 (call-function on-error
"Failed to merge ~S with ~S into an absolute pathname"
2754 path default-pathname
))))
2755 (t (call-function on-error
2756 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
2759 (defun subpathp (maybe-subpath base-pathname
)
2760 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
2761 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
2762 (and (pathnamep maybe-subpath
) (pathnamep base-pathname
)
2763 (absolute-pathname-p maybe-subpath
) (absolute-pathname-p base-pathname
)
2764 (directory-pathname-p base-pathname
) (not (wild-pathname-p base-pathname
))
2765 (pathname-equal (pathname-root maybe-subpath
) (pathname-root base-pathname
))
2766 (with-pathname-defaults (*nil-pathname
*)
2767 (let ((enough (enough-namestring maybe-subpath base-pathname
)))
2768 (and (relative-pathname-p enough
) (pathname enough
))))))
2770 (defun enough-pathname (maybe-subpath base-pathname
)
2771 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
2772 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
2773 (let ((sub (when maybe-subpath
(pathname maybe-subpath
)))
2774 (base (when base-pathname
(ensure-absolute-pathname (pathname base-pathname
)))))
2775 (or (and base
(subpathp sub base
)) sub
)))
2777 (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk
)
2778 "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
2779 or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
2780 given DEFAULTS-PATHNAME as a base pathname."
2781 (let ((enough (enough-pathname maybe-subpath defaults-pathname
))
2782 (*default-pathname-defaults
* (or defaults-pathname
*default-pathname-defaults
*)))
2783 (funcall thunk enough
)))
2785 (defmacro with-enough-pathname
((pathname-var &key
(pathname pathname-var
)
2786 (defaults *default-pathname-defaults
*))
2788 "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
2789 `(call-with-enough-pathname ,pathname
,defaults
#'(lambda (,pathname-var
) ,@body
))))
2792 ;;; Wildcard pathnames
2793 (with-upgradability ()
2794 (defparameter *wild
* (or #+cormanlisp
"*" :wild
)
2795 "Wild component for use with MAKE-PATHNAME")
2796 (defparameter *wild-directory-component
* (or :wild
)
2797 "Wild directory component for use with MAKE-PATHNAME")
2798 (defparameter *wild-inferiors-component
* (or :wild-inferiors
)
2799 "Wild-inferiors directory component for use with MAKE-PATHNAME")
2800 (defparameter *wild-file
*
2801 (make-pathname :directory nil
:name
*wild
* :type
*wild
*
2802 :version
(or #-
(or allegro abcl xcl
) *wild
*))
2803 "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME")
2804 (defparameter *wild-file-for-directory
*
2805 (make-pathname :directory nil
:name
*wild
* :type
(or #-
(or clisp gcl
) *wild
*)
2806 :version
(or #-
(or allegro abcl clisp gcl xcl
) *wild
*))
2807 "A pathname object with wildcards for matching any file with DIRECTORY")
2808 (defparameter *wild-directory
*
2809 (make-pathname :directory
`(:relative
,*wild-directory-component
*)
2810 :name nil
:type nil
:version nil
)
2811 "A pathname object with wildcards for matching any subdirectory")
2812 (defparameter *wild-inferiors
*
2813 (make-pathname :directory
`(:relative
,*wild-inferiors-component
*)
2814 :name nil
:type nil
:version nil
)
2815 "A pathname object with wildcards for matching any recursive subdirectory")
2816 (defparameter *wild-path
*
2817 (merge-pathnames* *wild-file
* *wild-inferiors
*)
2818 "A pathname object with wildcards for matching any file in any recursive subdirectory")
2820 (defun wilden (path)
2821 "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory"
2822 (merge-pathnames* *wild-path
* path
)))
2825 ;;; Translate a pathname
2826 (with-upgradability ()
2827 (defun relativize-directory-component (directory-component)
2828 "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component"
2829 (let ((directory (normalize-pathname-directory-component directory-component
)))
2831 ((stringp directory
)
2832 (list :relative directory
))
2833 ((eq (car directory
) :absolute
)
2834 (cons :relative
(cdr directory
)))
2838 (defun relativize-pathname-directory (pathspec)
2839 "Given a PATHNAME, return a relative pathname with otherwise the same components"
2840 (let ((p (pathname pathspec
)))
2842 :directory
(relativize-directory-component (pathname-directory p
))
2845 (defun directory-separator-for-host (&optional
(pathname *default-pathname-defaults
*))
2846 "Given a PATHNAME, return the character used to delimit directory names on this host and device."
2847 (let ((foo (make-pathname :directory
'(:absolute
"FOO") :defaults pathname
)))
2848 (last-char (namestring foo
))))
2851 (defun directorize-pathname-host-device (pathname)
2852 "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
2853 added to its DIRECTORY component. This is useful for output translations."
2856 (when (physical-pathname-p pathname
)
2857 (return-from directorize-pathname-host-device pathname
))))
2858 (let* ((root (pathname-root pathname
))
2859 (wild-root (wilden root
))
2860 (absolute-pathname (merge-pathnames* pathname root
))
2861 (separator (directory-separator-for-host root
))
2862 (root-namestring (namestring root
))
2865 #'(lambda (x) (or (eql x
#\
:)
2868 (multiple-value-bind (relative path filename
)
2869 (split-unix-namestring-directory-components root-string
:ensure-directory t
)
2870 (declare (ignore relative filename
))
2871 (let ((new-base (make-pathname :defaults root
:directory
`(:absolute
,@path
))))
2872 (translate-pathname absolute-pathname wild-root
(wilden new-base
))))))
2875 (defun directorize-pathname-host-device (pathname)
2876 (let ((scheme (ext:pathname-scheme pathname
))
2877 (host (pathname-host pathname
))
2878 (port (ext:pathname-port pathname
))
2879 (directory (pathname-directory pathname
)))
2880 (flet ((specificp (x) (and x
(not (eq x
:unspecific
)))))
2881 (if (or (specificp port
)
2882 (and (specificp host
) (plusp (length host
)))
2885 (when (specificp port
)
2886 (setf prefix
(format nil
":~D" port
)))
2887 (when (and (specificp host
) (plusp (length host
)))
2888 (setf prefix
(strcat host prefix
)))
2889 (setf prefix
(strcat ":" prefix
))
2890 (when (specificp scheme
)
2891 (setf prefix
(strcat scheme prefix
)))
2892 (assert (and directory
(eq (first directory
) :absolute
)))
2893 (make-pathname :directory
`(:absolute
,prefix
,@(rest directory
))
2894 :defaults pathname
)))
2897 (defun* (translate-pathname*) (path absolute-source destination
&optional root source
)
2898 "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
2899 PATH is the pathname to be translated.
2900 ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
2901 DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE,
2902 or a relative pathname, to be merged with ROOT and used as destination for translate-pathname
2903 or an absolute pathname, to be used as destination for translate-pathname.
2904 In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE."
2905 (declare (ignore source
))
2907 ((functionp destination
)
2908 (funcall destination path absolute-source
))
2911 ((not (pathnamep destination
))
2912 (parameter-error "~S: Invalid destination" 'translate-pathname
*))
2913 ((not (absolute-pathname-p destination
))
2914 (translate-pathname path absolute-source
(merge-pathnames* destination root
)))
2916 (translate-pathname (directorize-pathname-host-device path
) absolute-source destination
))
2918 (translate-pathname path absolute-source destination
))))
2920 (defvar *output-translation-function
* 'identity
2921 "Hook for output translations.
2923 This function needs to be idempotent, so that actions can work
2924 whether their inputs were translated or not,
2925 which they will be if we are composing operations. e.g. if some
2926 create-lisp-op creates a lisp file from some higher-level input,
2927 you need to still be able to use compile-op on that lisp file."))
2928 ;;;; -------------------------------------------------------------------------
2929 ;;;; Portability layer around Common Lisp filesystem access
2931 (uiop/package
:define-package
:uiop
/filesystem
2932 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/os
:uiop
/pathname
)
2934 ;; Native namestrings
2935 #:native-namestring
#:parse-native-namestring
2936 ;; Probing the filesystem
2937 #:truename
* #:safe-file-write-date
#:probe-file
* #:directory-exists-p
#:file-exists-p
2938 #:directory
* #:filter-logical-directory-results
#:directory-files
#:subdirectories
2939 #:collect-sub
*directories
2940 ;; Resolving symlinks somewhat
2941 #:truenamize
#:resolve-symlinks
#:*resolve-symlinks
* #:resolve-symlinks
*
2943 #:get-pathname-defaults
#:call-with-current-directory
#:with-current-directory
2944 ;; Environment pathnames
2945 #:inter-directory-separator
#:split-native-pathnames-string
2946 #:getenv-pathname
#:getenv-pathnames
2947 #:getenv-absolute-directory
#:getenv-absolute-directories
2948 #:lisp-implementation-directory
#:lisp-implementation-pathname-p
2949 ;; Simple filesystem operations
2950 #:ensure-all-directories-exist
2951 #:rename-file-overwriting-target
2952 #:delete-file-if-exists
#:delete-empty-directory
#:delete-directory-tree
))
2953 (in-package :uiop
/filesystem
)
2955 ;;; Native namestrings, as seen by the operating system calls rather than Lisp
2956 (with-upgradability ()
2957 (defun native-namestring (x)
2958 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
2960 (let ((p (pathname x
)))
2961 #+clozure
(with-pathname-defaults () (ccl:native-translated-namestring p
)) ; see ccl bug 978
2962 #+(or cmucl scl
) (ext:unix-namestring p nil
)
2963 #+sbcl
(sb-ext:native-namestring p
)
2964 #-
(or clozure cmucl sbcl scl
)
2966 ((os-unix-p) (unix-namestring p
))
2967 (t (namestring p
))))))
2969 (defun parse-native-namestring (string &rest constraints
&key ensure-directory
&allow-other-keys
)
2970 "From a native namestring suitable for use by the operating system, return
2971 a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
2972 (check-type string
(or string null
))
2975 (with-pathname-defaults ()
2976 #+clozure
(ccl:native-to-pathname string
)
2977 #+cmucl
(uiop/os
::parse-unix-namestring
* string
)
2978 #+sbcl
(sb-ext:parse-native-namestring string
)
2979 #+scl
(lisp::parse-unix-namestring string
)
2980 #-
(or clozure cmucl sbcl scl
)
2982 ((os-unix-p) (parse-unix-namestring string
:ensure-directory ensure-directory
))
2983 (t (parse-namestring string
))))))
2985 (if ensure-directory
2986 (and pathname
(ensure-directory-pathname pathname
))
2988 (apply 'ensure-pathname pathname constraints
))))
2991 ;;; Probing the filesystem
2992 (with-upgradability ()
2993 (defun truename* (p)
2994 "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
2996 (when (stringp p
) (setf p
(with-pathname-defaults () (parse-namestring p
))))
2998 (or (ignore-errors (truename p
))
2999 ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
3000 ;; a trailing directory separator, causes an error on some lisps.
3001 #+(or clisp gcl
) (if-let (d (ensure-directory-pathname p nil
)) (ignore-errors (truename d
)))))))
3003 (defun safe-file-write-date (pathname)
3004 "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
3005 ;; If FILE-WRITE-DATE returns NIL, it's possible that
3006 ;; the user or some other agent has deleted an input file.
3007 ;; Also, generated files will not exist at the time planning is done
3008 ;; and calls compute-action-stamp which calls safe-file-write-date.
3009 ;; So it is very possible that we can't get a valid file-write-date,
3010 ;; and we can survive and we will continue the planning
3011 ;; as if the file were very old.
3012 ;; (or should we treat the case in a different, special way?)
3014 (handler-case (file-write-date (physicalize-pathname pathname
))
3015 (file-error () nil
))))
3017 (defun probe-file* (p &key truename
)
3018 "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
3019 probes the filesystem for a file or directory with given pathname.
3020 If it exists, return its truename if TRUENAME is true,
3021 or the original (parsed) pathname if it is false (the default)."
3024 (setf p
(funcall 'ensure-pathname p
3027 :ensure-absolute t
:defaults
'get-pathname-defaults
3032 (probe-file p
:follow-symlinks truename
)
3036 (let ((kind (car (si::stat p
))))
3037 (when (eq kind
:link
)
3038 (setf kind
(ignore-errors (car (si::stat
(truename* p
))))))
3043 ((file-pathname-p p
) p
)
3044 ((directory-pathname-p p
)
3045 (subpathname p
(car (last (pathname-directory p
)))))))
3046 (:directory
(ensure-directory-pathname p
)))))
3048 #.
(let* ((fs (or #-os-windows
(find-symbol* '#:file-stat
:posix nil
)))
3049 (pp (find-symbol* '#:probe-pathname
:ext nil
)))
3054 (truename* (ignore-errors (ensure-directory-pathname p
)))))
3056 (fs `(and (,fs p
) p
))
3057 (pp `(nth-value 1 (,pp p
)))
3058 (t '(or (and (truename* p
) p
)
3059 (if-let (d (ensure-directory-pathname p
))
3060 (and (truename* d
) d
)))))))
3061 #-
(or allegro clisp gcl
)
3065 #+(or cmucl scl
) (unix:unix-stat
(ext:unix-namestring p
))
3066 #+(and lispworks os-unix
) (system:get-file-stat p
)
3067 #+sbcl
(sb-unix:unix-stat
(sb-ext:native-namestring p
))
3068 #-
(or cmucl
(and lispworks os-unix
) sbcl scl
) (file-write-date p
)
3071 (defun directory-exists-p (x)
3072 "Is X the name of a directory that exists on the filesystem?"
3074 (excl:probe-directory x
)
3076 (handler-case (ext:probe-directory x
)
3077 (sys::simple-file-error
()
3079 #-
(or allegro clisp
)
3080 (let ((p (probe-file* x
:truename t
)))
3081 (and (directory-pathname-p p
) p
)))
3083 (defun file-exists-p (x)
3084 "Is X the name of a file that exists on the filesystem?"
3085 (let ((p (probe-file* x
:truename t
)))
3086 (and (file-pathname-p p
) p
)))
3088 (defun directory* (pathname-spec &rest keys
&key
&allow-other-keys
)
3089 "Return a list of the entries in a directory by calling DIRECTORY.
3090 Try to override the defaults to not resolving symlinks, if implementation allows."
3091 (apply 'directory pathname-spec
3092 (append keys
'#.
(or #+allegro
'(:directories-are-files nil
:follow-symbolic-links nil
)
3093 #+(or clozure digitool
) '(:follow-links nil
)
3094 #+clisp
'(:circle t
:if-does-not-exist
:ignore
)
3095 #+(or cmucl scl
) '(:follow-links nil
:truenamep nil
)
3096 #+lispworks
'(:link-transparency nil
)
3097 #+sbcl
(when (find-symbol* :resolve-symlinks
'#:sb-impl nil
)
3098 '(:resolve-symlinks nil
))))))
3100 (defun filter-logical-directory-results (directory entries merger
)
3101 "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
3102 given ENTRIES in the DIRECTORY, remove the entries which are physical yet
3103 when transformed by MERGER have a different TRUENAME.
3104 Also remove duplicates as may appear with some translation rules.
3105 This function is used as a helper to DIRECTORY-FILES to avoid invalid entries
3106 when using logical-pathnames."
3107 (if (logical-pathname-p directory
)
3108 (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
3109 ;; Try hard to not resolve logical-pathname into physical pathnames;
3110 ;; otherwise logical-pathname users/lovers will be disappointed.
3111 ;; If directory* could use some implementation-dependent magic,
3112 ;; we will have logical pathnames already; otherwise,
3113 ;; we only keep pathnames for which specifying the name and
3114 ;; translating the LPN commute.
3115 (loop :for f
:in entries
3116 :for p
= (or (and (logical-pathname-p f
) f
)
3117 (let* ((u (ignore-errors (call-function merger f
))))
3118 ;; The first u avoids a cumbersome (truename u) error.
3119 ;; At this point f should already be a truename,
3120 ;; but isn't quite in CLISP, for it doesn't have :version :newest
3121 (and u
(equal (truename* u
) (truename* f
)) u
)))
3123 :test
'pathname-equal
)
3126 (defun directory-files (directory &optional
(pattern *wild-file-for-directory
*))
3127 "Return a list of the files in a directory according to the PATTERN.
3128 Subdirectories should NOT be returned.
3129 PATTERN defaults to a pattern carefully chosen based on the implementation;
3130 override the default at your own risk.
3131 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
3132 but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
3133 (let ((dir (pathname directory
)))
3134 (when (logical-pathname-p dir
)
3135 ;; Because of the filtering we do below,
3136 ;; logical pathnames have restrictions on wild patterns.
3137 ;; Not that the results are very portable when you use these patterns on physical pathnames.
3138 (when (wild-pathname-p dir
)
3139 (parameter-error "~S: Invalid wild pattern in logical directory ~S"
3140 'directory-files directory
))
3141 (unless (member (pathname-directory pattern
) '(() (:relative
)) :test
'equal
)
3142 (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory
))
3143 (setf pattern
(make-pathname-logical pattern
(pathname-host dir
))))
3144 (let* ((pat (merge-pathnames* pattern dir
))
3145 (entries (ignore-errors (directory* pat
))))
3146 (remove-if 'directory-pathname-p
3147 (filter-logical-directory-results
3150 (make-pathname :defaults dir
3151 :name
(make-pathname-component-logical (pathname-name f
))
3152 :type
(make-pathname-component-logical (pathname-type f
))
3153 :version
(make-pathname-component-logical (pathname-version f
)))))))))
3155 (defun subdirectories (directory)
3156 "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
3157 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
3158 (let* ((directory (ensure-directory-pathname directory
))
3159 #-
(or abcl cormanlisp genera xcl
)
3160 (wild (merge-pathnames*
3161 #-
(or abcl allegro cmucl lispworks sbcl scl xcl
)
3163 #+(or abcl allegro cmucl lispworks sbcl scl xcl
) "*.*"
3166 #-
(or abcl cormanlisp genera xcl
)
3168 (directory* wild .
#.
(or #+clozure
'(:directories t
:files nil
)
3169 #+mcl
'(:directories t
))))
3170 #+(or abcl xcl
) (system:list-directory directory
)
3171 #+cormanlisp
(cl::directory-subdirs directory
)
3172 #+genera
(handler-case (fs:directory-list directory
) (fs:directory-not-found
() nil
)))
3173 #+(or abcl allegro cmucl genera lispworks sbcl scl xcl
)
3174 (dirs (loop :for x
:in dirs
3175 :for d
= #+(or abcl xcl
) (extensions:probe-directory x
)
3176 #+allegro
(excl:probe-directory x
)
3177 #+(or cmucl sbcl scl
) (directory-pathname-p x
)
3178 #+genera
(getf (cdr x
) :directory
)
3179 #+lispworks
(lw:file-directory-p x
)
3180 :when d
:collect
#+(or abcl allegro xcl
) (ensure-directory-pathname d
)
3181 #+genera
(ensure-directory-pathname (first x
))
3182 #+(or cmucl lispworks sbcl scl
) x
)))
3183 (filter-logical-directory-results
3185 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory
))
3186 '(:absolute
)))) ; because allegro returns NIL for #p"FOO:"
3188 (let ((dir (normalize-pathname-directory-component (pathname-directory d
))))
3189 (and (consp dir
) (consp (cdr dir
))
3191 :defaults directory
:name nil
:type nil
:version nil
3192 :directory
(append prefix
(make-pathname-component-logical (last dir
)))))))))))
3194 (defun collect-sub*directories
(directory collectp recursep collector
)
3195 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
3196 call-function the COLLECTOR function designator on the directory,
3197 and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
3198 This function will thus let you traverse a filesystem hierarchy,
3199 superseding the functionality of CL-FAD:WALK-DIRECTORY.
3200 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
3201 (when (call-function collectp directory
)
3202 (call-function collector directory
)
3203 (dolist (subdir (subdirectories directory
))
3204 (when (call-function recursep subdir
)
3205 (collect-sub*directories subdir collectp recursep collector
))))))
3207 ;;; Resolving symlinks somewhat
3208 (with-upgradability ()
3209 (defun truenamize (pathname)
3210 "Resolve as much of a pathname as possible"
3212 (when (typep pathname
'(or null logical-pathname
)) (return pathname
))
3214 (unless (absolute-pathname-p p
)
3215 (setf p
(or (absolute-pathname-p (ensure-absolute-pathname p
'get-pathname-defaults nil
))
3217 (when (logical-pathname-p p
) (return p
))
3218 (let ((found (probe-file* p
:truename t
)))
3219 (when found
(return found
)))
3220 (let* ((directory (normalize-pathname-directory-component (pathname-directory p
)))
3221 (up-components (reverse (rest directory
)))
3222 (down-components ()))
3223 (assert (eq :absolute
(first directory
)))
3224 (loop :while up-components
:do
3227 (probe-file* (make-pathname :directory
`(:absolute
,@(reverse up-components
))
3228 :name nil
:type nil
:version nil
:defaults p
))))
3232 (make-pathname :directory
`(:relative
,@down-components
)
3234 (ensure-directory-pathname parent
))))
3235 (return simplified
)))
3236 (push (pop up-components
) down-components
)
3237 :finally
(return p
))))))
3239 (defun resolve-symlinks (path)
3240 "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
3241 #-allegro
(truenamize path
)
3243 (if (physical-pathname-p path
)
3244 (or (ignore-errors (excl:pathname-resolve-symbolic-links path
)) path
)
3247 (defvar *resolve-symlinks
* t
3248 "Determine whether or not ASDF resolves symlinks when defining systems.
3251 (defun resolve-symlinks* (path)
3252 "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
3253 (if *resolve-symlinks
*
3254 (and path
(resolve-symlinks path
))
3258 ;;; Check pathname constraints
3259 (with-upgradability ()
3260 (defun ensure-pathname
3263 defaults type dot-dot namestring
3266 want-logical want-physical ensure-physical
3267 want-relative want-absolute ensure-absolute ensure-subpath
3268 want-non-wild want-wild wilden
3269 want-file want-directory ensure-directory
3270 want-existing ensure-directories-exist
3271 truename resolve-symlinks truenamize
3272 &aux
(p pathname
)) ;; mutable working copy, preserve original
3273 "Coerces its argument into a PATHNAME,
3274 optionally doing some transformations and checking specified constraints.
3276 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
3278 If the argument is a STRING, it is first converted to a pathname via
3279 PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
3280 depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
3281 or else by using CALL-FUNCTION on the NAMESTRING argument;
3282 if :UNIX is specified (or NIL, the default, which specifies the same thing),
3283 then PARSE-UNIX-NAMESTRING it is called with the keywords
3284 DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
3285 the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
3287 The pathname passed or resulting from parsing the string
3288 is then subjected to all the checks and transformations below are run.
3290 Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
3291 The boolean T is an alias for ERROR.
3292 ERROR means that an error will be raised if the constraint is not satisfied.
3293 CERROR means that an continuable error will be raised if the constraint is not satisfied.
3294 IGNORE means just return NIL instead of the pathname.
3296 The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
3297 that will be called with the the following arguments:
3298 a generic format string for ensure pathname, the pathname,
3299 the keyword argument corresponding to the failed check or transformation,
3300 a format string for the reason ENSURE-PATHNAME failed,
3301 and a list with arguments to that format string.
3302 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
3303 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
3305 The transformations and constraint checks are done in this order,
3306 which is also the order in the lambda-list:
3308 EMPTY-IS-NIL returns NIL if the argument is an empty string.
3309 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
3310 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
3311 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
3312 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
3313 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
3314 WANT-RELATIVE checks that pathname has a relative directory component
3315 WANT-ABSOLUTE checks that pathname does have an absolute directory component
3316 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
3317 that the result absolute is an absolute pathname indeed.
3318 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
3319 WANT-FILE checks that pathname has a non-nil FILE component
3320 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
3321 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
3322 any file and type components as being actually a last directory component.
3323 WANT-NON-WILD checks that pathname is not a wild pathname
3324 WANT-WILD checks that pathname is a wild pathname
3325 WILDEN merges the pathname with **/*.*.* if it is not wild
3326 WANT-EXISTING checks that a file (or directory) exists with that pathname.
3327 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
3328 TRUENAME replaces the pathname by its truename, or errors if not possible.
3329 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
3330 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
3332 (flet ((report-error (keyword description
&rest arguments
)
3333 (call-function (or on-error
'error
)
3334 "Invalid pathname ~S: ~*~?"
3335 pathname keyword description arguments
)))
3336 (macrolet ((err (constraint &rest arguments
)
3337 `(report-error ',(intern* constraint
:keyword
) ,@arguments
))
3338 (check (constraint condition
&rest arguments
)
3340 (unless ,condition
(err ,constraint
,@arguments
))))
3341 (transform (transform condition expr
)
3343 (,@(if condition
`(when ,condition
) '(progn))
3346 ((or null pathname
))
3348 (when (and (emptyp p
) empty-is-nil
)
3349 (return-from ensure-pathname nil
))
3350 (setf p
(case namestring
3352 (parse-unix-namestring
3353 p
:defaults defaults
:type type
:dot-dot dot-dot
3354 :ensure-directory ensure-directory
:want-relative want-relative
))
3356 (parse-native-namestring p
))
3358 (parse-namestring p
))
3360 (call-function namestring p
))))))
3364 (check want-pathname
(pathnamep p
) "Expected a pathname, not NIL")
3366 (check want-logical
(logical-pathname-p p
) "Expected a logical pathname")
3367 (check want-physical
(physical-pathname-p p
) "Expected a physical pathname")
3368 (transform ensure-physical
() (physicalize-pathname p
))
3369 (check ensure-physical
(physical-pathname-p p
) "Could not translate to a physical pathname")
3370 (check want-relative
(relative-pathname-p p
) "Expected a relative pathname")
3371 (check want-absolute
(absolute-pathname-p p
) "Expected an absolute pathname")
3372 (transform ensure-absolute
(not (absolute-pathname-p p
))
3373 (ensure-absolute-pathname p defaults
(list #'report-error
:ensure-absolute
"~@?")))
3374 (check ensure-absolute
(absolute-pathname-p p
)
3375 "Could not make into an absolute pathname even after merging with ~S" defaults
)
3376 (check ensure-subpath
(absolute-pathname-p defaults
)
3377 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults
)
3378 (check ensure-subpath
(subpathp p defaults
) "is not a sub pathname of ~S" defaults
)
3379 (check want-file
(file-pathname-p p
) "Expected a file pathname")
3380 (check want-directory
(directory-pathname-p p
) "Expected a directory pathname")
3381 (transform ensure-directory
(not (directory-pathname-p p
)) (ensure-directory-pathname p
))
3382 (check want-non-wild
(not (wild-pathname-p p
)) "Expected a non-wildcard pathname")
3383 (check want-wild
(wild-pathname-p p
) "Expected a wildcard pathname")
3384 (transform wilden
(not (wild-pathname-p p
)) (wilden p
))
3386 (let ((existing (probe-file* p
:truename truename
)))
3390 (err want-existing
"Expected an existing pathname"))))
3391 (when ensure-directories-exist
(ensure-directories-exist p
))
3393 (let ((truename (truename* p
)))
3396 (err truename
"Can't get a truename for pathname"))))
3397 (transform resolve-symlinks
() (resolve-symlinks p
))
3398 (transform truenamize
() (truenamize p
))
3402 ;;; Pathname defaults
3403 (with-upgradability ()
3404 (defun get-pathname-defaults (&optional
(defaults *default-pathname-defaults
*))
3405 "Find the actual DEFAULTS to use for pathnames, including
3406 resolving them with respect to GETCWD if the DEFAULTS were relative"
3407 (or (absolute-pathname-p defaults
)
3408 (merge-pathnames* defaults
(getcwd))))
3410 (defun call-with-current-directory (dir thunk
)
3411 "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
3412 Note that this operation is usually NOT thread-safe."
3414 (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir
))))
3416 (*default-pathname-defaults
* dir
))
3423 (defmacro with-current-directory
((&optional dir
) &body body
)
3424 "Call BODY while the POSIX current working directory is set to DIR"
3425 `(call-with-current-directory ,dir
#'(lambda () ,@body
))))
3428 ;;; Environment pathnames
3429 (with-upgradability ()
3430 (defun inter-directory-separator ()
3431 "What character does the current OS conventionally uses to separate directories?"
3432 (os-cond ((os-unix-p) #\
:) (t #\
;)))
3434 (defun split-native-pathnames-string (string &rest constraints
&key
&allow-other-keys
)
3435 "Given a string of pathnames specified in native OS syntax, separate them in a list,
3436 check constraints and normalize each one as per ENSURE-PATHNAME,
3437 where an empty string denotes NIL."
3438 (loop :for namestring
:in
(split-string string
:separator
(string (inter-directory-separator)))
3439 :collect
(unless (emptyp namestring
) (apply 'parse-native-namestring namestring constraints
))))
3441 (defun getenv-pathname (x &rest constraints
&key ensure-directory want-directory on-error
&allow-other-keys
)
3442 "Extract a pathname from a user-configured environment variable, as per native OS,
3443 check constraints and normalize as per ENSURE-PATHNAME."
3444 ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
3445 (apply 'parse-native-namestring
(getenvp x
)
3446 :ensure-directory
(or ensure-directory want-directory
)
3447 :on-error
(or on-error
3448 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname
,x
))
3450 (defun getenv-pathnames (x &rest constraints
&key on-error
&allow-other-keys
)
3451 "Extract a list of pathname from a user-configured environment variable, as per native OS,
3452 check constraints and normalize each one as per ENSURE-PATHNAME.
3453 Any empty entries in the environment variable X will be returned as NILs."
3454 (unless (getf constraints
:empty-is-nil t
)
3455 (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames
))
3456 (apply 'split-native-pathnames-string
(getenvp x
)
3457 :on-error
(or on-error
3458 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames
,x
))
3461 (defun getenv-absolute-directory (x)
3462 "Extract an absolute directory pathname from a user-configured environment variable,
3464 (getenv-pathname x
:want-absolute t
:ensure-directory t
))
3465 (defun getenv-absolute-directories (x)
3466 "Extract a list of absolute directories from a user-configured environment variable,
3467 as per native OS. Any empty entries in the environment variable X will be returned as
3469 (getenv-pathnames x
:want-absolute t
:ensure-directory t
))
3471 (defun lisp-implementation-directory (&key truename
)
3472 "Where are the system files of the current installation of the CL implementation?"
3473 (declare (ignorable truename
))
3475 #+abcl extensions
:*lisp-home
*
3476 #+(or allegro clasp ecl mkcl
) #p
"SYS:"
3477 #+clisp custom
:*lib-directory
*
3479 #+cmucl
(ignore-errors (pathname-parent-directory-pathname (truename #p
"modules:")))
3480 #+gcl system
::*system-directory
*
3481 #+lispworks lispworks
:*lispworks-directory
*
3482 #+sbcl
(if-let (it (find-symbol* :sbcl-homedir-pathname
:sb-int nil
))
3484 (getenv-pathname "SBCL_HOME" :ensure-directory t
))
3485 #+scl
(ignore-errors (pathname-parent-directory-pathname (truename #p
"file://modules/")))
3486 #+xcl ext
:*xcl-home
*))
3487 (if (and dir truename
)
3491 (defun lisp-implementation-pathname-p (pathname)
3492 "Is the PATHNAME under the current installation of the CL implementation?"
3493 ;; Other builtin systems are those under the implementation directory
3495 (if-let (impdir (lisp-implementation-directory))
3496 (or (subpathp pathname impdir
)
3497 (when *resolve-symlinks
*
3498 (if-let (truename (truename* pathname
))
3499 (if-let (trueimpdir (truename* impdir
))
3500 (subpathp truename trueimpdir
)))))))
3504 ;;; Simple filesystem operations
3505 (with-upgradability ()
3506 (defun ensure-all-directories-exist (pathnames)
3507 "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
3508 (dolist (pathname pathnames
)
3510 (ensure-directories-exist (physicalize-pathname pathname
)))))
3512 (defun delete-file-if-exists (x)
3513 "Delete a file X if it already exists"
3514 (when x
(handler-case (delete-file x
) (file-error () nil
))))
3516 (defun rename-file-overwriting-target (source target
)
3517 "Rename a file, overwriting any previous file with the TARGET name,
3518 in an atomic way if the implementation allows."
3519 (let ((source (ensure-pathname source
:namestring
:lisp
:ensure-physical t
:want-file t
))
3520 (target (ensure-pathname target
:namestring
:lisp
:ensure-physical t
:want-file t
)))
3521 #+clisp
;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
3522 (progn (funcall 'require
"syscalls")
3523 (symbol-call :posix
:copy-file source target
:method
:rename
))
3524 #+(and sbcl os-windows
) (delete-file-if-exists target
) ;; not atomic
3526 (rename-file source target
3527 #+(or clasp clozure ecl
) :if-exists
3528 #+clozure
:rename-and-delete
#+(or clasp ecl
) t
)))
3530 (defun delete-empty-directory (directory-pathname)
3531 "Delete an empty directory"
3532 #+(or abcl digitool gcl
) (delete-file directory-pathname
)
3533 #+allegro
(excl:delete-directory directory-pathname
)
3534 #+clisp
(ext:delete-directory directory-pathname
)
3535 #+clozure
(ccl::delete-empty-directory directory-pathname
)
3536 #+(or cmucl scl
) (multiple-value-bind (ok errno
)
3537 (unix:unix-rmdir
(native-namestring directory-pathname
))
3539 #+cmucl
(error "Error number ~A when trying to delete directory ~A"
3540 errno directory-pathname
)
3541 #+scl
(error "~@<Error deleting ~S: ~A~@:>"
3542 directory-pathname
(unix:get-unix-error-msg errno
))))
3543 #+cormanlisp
(win32:delete-directory directory-pathname
)
3544 #+(or clasp ecl
) (si:rmdir directory-pathname
)
3545 #+genera
(fs:delete-directory directory-pathname
)
3546 #+lispworks
(lw:delete-directory directory-pathname
)
3547 #+mkcl
(mkcl:rmdir directory-pathname
)
3548 #+sbcl
#.
(if-let (dd (find-symbol* :delete-directory
:sb-ext nil
))
3549 `(,dd directory-pathname
) ;; requires SBCL 1.0.44 or later
3550 `(progn (require :sb-posix
) (symbol-call :sb-posix
:rmdir directory-pathname
)))
3551 #+xcl
(symbol-call :uiop
:run-program
`("rmdir" ,(native-namestring directory-pathname
)))
3552 #-
(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl
)
3553 (not-implemented-error 'delete-empty-directory
"(on your platform)")) ; genera
3555 (defun delete-directory-tree (directory-pathname &key
(validate nil validatep
) (if-does-not-exist :error
))
3556 "Delete a directory including all its recursive contents, aka rm -rf.
3558 To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
3559 a physical non-wildcard directory pathname (not namestring).
3561 If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
3562 if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
3564 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
3565 the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
3566 which in practice is thus compulsory, and validates by returning a non-NIL result.
3567 If you're suicidal or extremely confident, just use :VALIDATE T."
3568 (check-type if-does-not-exist
(member :error
:ignore
))
3570 ((not (and (pathnamep directory-pathname
) (directory-pathname-p directory-pathname
)
3571 (physical-pathname-p directory-pathname
) (not (wild-pathname-p directory-pathname
))))
3572 (parameter-error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
3573 'delete-directory-tree directory-pathname
))
3575 (parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
3576 'delete-directory-tree directory-pathname
))
3577 ((not (call-function validate directory-pathname
))
3578 (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
3579 'delete-directory-tree directory-pathname validate
))
3580 ((not (directory-exists-p directory-pathname
))
3581 (ecase if-does-not-exist
3583 (error "~S was asked to delete ~S but the directory does not exist"
3584 'delete-directory-tree directory-pathname
))
3586 #-
(or allegro cmucl clozure genera sbcl scl
)
3587 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
3588 ;; except on implementations where we can prevent DIRECTORY from following symlinks;
3589 ;; instead spawn a standard external program to do the dirty work.
3590 (symbol-call :uiop
:run-program
`("rm" "-rf" ,(native-namestring directory-pathname
))))
3592 ;; On supported implementation, call supported system functions
3593 #+allegro
(symbol-call :excl.osi
:delete-directory-and-files
3594 directory-pathname
:if-does-not-exist if-does-not-exist
)
3595 #+clozure
(ccl:delete-directory directory-pathname
)
3596 #+genera
(fs:delete-directory directory-pathname
:confirm nil
)
3597 #+sbcl
#.
(if-let (dd (find-symbol* :delete-directory
:sb-ext nil
))
3598 `(,dd directory-pathname
:recursive t
) ;; requires SBCL 1.0.44 or later
3599 '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree
))
3600 ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
3601 ;; do things the hard way.
3602 #-
(or allegro clozure genera sbcl
)
3603 (let ((sub*directories
3604 (while-collecting (c)
3605 (collect-sub*directories directory-pathname t t
#'c
))))
3606 (dolist (d (nreverse sub
*directories
))
3607 (map () 'delete-file
(directory-files d
))
3608 (delete-empty-directory d
)))))))
3609 ;;;; ---------------------------------------------------------------------------
3610 ;;;; Utilities related to streams
3612 (uiop/package
:define-package
:uiop
/stream
3613 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/os
:uiop
/pathname
:uiop
/filesystem
)
3615 #:*default-stream-element-type
*
3616 #:*stdin
* #:setup-stdin
#:*stdout
* #:setup-stdout
#:*stderr
* #:setup-stderr
3617 #:detect-encoding
#:*encoding-detection-hook
* #:always-default-encoding
3618 #:encoding-external-format
#:*encoding-external-format-hook
* #:default-encoding-external-format
3619 #:*default-encoding
* #:*utf-8-external-format
*
3620 #:with-safe-io-syntax
#:call-with-safe-io-syntax
#:safe-read-from-string
3621 #:with-output
#:output-string
#:with-input
#:input-string
3622 #:with-input-file
#:call-with-input-file
#:with-output-file
#:call-with-output-file
3623 #:null-device-pathname
#:call-with-null-input
#:with-null-input
3624 #:call-with-null-output
#:with-null-output
3625 #:finish-outputs
#:format
! #:safe-format
!
3626 #:copy-stream-to-stream
#:concatenate-files
#:copy-file
3627 #:slurp-stream-string
#:slurp-stream-lines
#:slurp-stream-line
3628 #:slurp-stream-forms
#:slurp-stream-form
3629 #:read-file-string
#:read-file-line
#:read-file-lines
#:safe-read-file-line
3630 #:read-file-forms
#:read-file-form
#:safe-read-file-form
3631 #:eval-input
#:eval-thunk
#:standard-eval-thunk
3633 #:file-stream-p
#:file-or-synonym-stream-p
3635 #:*temporary-directory
* #:temporary-directory
#:default-temporary-directory
3636 #:setup-temporary-directory
3637 #:call-with-temporary-file
#:with-temporary-file
3638 #:add-pathname-suffix
#:tmpize-pathname
3639 #:call-with-staging-pathname
#:with-staging-pathname
))
3640 (in-package :uiop
/stream
)
3642 (with-upgradability ()
3643 (defvar *default-stream-element-type
*
3644 (or #+(or abcl cmucl cormanlisp scl xcl
) 'character
3645 #+lispworks
'lw
:simple-char
3647 "default element-type for open (depends on the current CL implementation)")
3649 (defvar *stdin
* *standard-input
*
3650 "the original standard input stream at startup")
3652 (defun setup-stdin ()
3654 #.
(or #+clozure
'ccl
::*stdin
*
3655 #+(or cmucl scl
) 'system
:*stdin
*
3656 #+(or clasp ecl
) 'ext
::+process-standard-input
+
3657 #+sbcl
'sb-sys
:*stdin
*
3658 '*standard-input
*)))
3660 (defvar *stdout
* *standard-output
*
3661 "the original standard output stream at startup")
3663 (defun setup-stdout ()
3665 #.
(or #+clozure
'ccl
::*stdout
*
3666 #+(or cmucl scl
) 'system
:*stdout
*
3667 #+(or clasp ecl
) 'ext
::+process-standard-output
+
3668 #+sbcl
'sb-sys
:*stdout
*
3669 '*standard-output
*)))
3671 (defvar *stderr
* *error-output
*
3672 "the original error output stream at startup")
3674 (defun setup-stderr ()
3676 #.
(or #+allegro
'excl
::*stderr
*
3677 #+clozure
'ccl
::*stderr
*
3678 #+(or cmucl scl
) 'system
:*stderr
*
3679 #+(or clasp ecl
) 'ext
::+process-error-output
+
3680 #+sbcl
'sb-sys
:*stderr
*
3683 ;; Run them now. In image.lisp, we'll register them to be run at image restart.
3684 (setup-stdin) (setup-stdout) (setup-stderr))
3687 ;;; Encodings (mostly hooks only; full support requires asdf-encodings)
3688 (with-upgradability ()
3689 (defparameter *default-encoding
*
3690 ;; preserve explicit user changes to something other than the legacy default :default
3691 (or (if-let (previous (and (boundp '*default-encoding
*) (symbol-value '*default-encoding
*)))
3692 (unless (eq previous
:default
) previous
))
3694 "Default encoding for source files.
3695 The default value :utf-8 is the portable thing.
3696 The legacy behavior was :default.
3697 If you (asdf:load-system :asdf-encodings) then
3698 you will have autodetection via *encoding-detection-hook* below,
3699 reading emacs-style -*- coding: utf-8 -*- specifications,
3700 and falling back to utf-8 or latin1 if nothing is specified.")
3702 (defparameter *utf-8-external-format
*
3703 (if (featurep :asdf-unicode
)
3704 (or #+clisp charset
:utf-8
:utf-8
)
3706 "Default :external-format argument to pass to CL:OPEN and also
3707 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
3708 On modern implementations, this will decode UTF-8 code points as CL characters.
3709 On legacy implementations, it may fall back on some 8-bit encoding,
3710 with non-ASCII code points being read as several CL characters;
3711 hopefully, if done consistently, that won't affect program behavior too much.")
3713 (defun always-default-encoding (pathname)
3714 "Trivial function to use as *encoding-detection-hook*,
3715 always 'detects' the *default-encoding*"
3716 (declare (ignore pathname
))
3719 (defvar *encoding-detection-hook
* #'always-default-encoding
3720 "Hook for an extension to define a function to automatically detect a file's encoding")
3722 (defun detect-encoding (pathname)
3723 "Detects the encoding of a specified file, going through user-configurable hooks"
3724 (if (and pathname
(not (directory-pathname-p pathname
)) (probe-file* pathname
))
3725 (funcall *encoding-detection-hook
* pathname
)
3726 *default-encoding
*))
3728 (defun default-encoding-external-format (encoding)
3729 "Default, ignorant, function to transform a character ENCODING as a
3730 portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
3731 Load system ASDF-ENCODINGS to hook in a better one."
3733 (:default
:default
) ;; for backward-compatibility only. Explicit usage discouraged.
3734 (:utf-8
*utf-8-external-format
*)
3736 (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding
)
3739 (defvar *encoding-external-format-hook
*
3740 #'default-encoding-external-format
3741 "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
3742 from non-default encodings to and implementation-defined external-format's")
3744 (defun encoding-external-format (encoding)
3745 "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
3746 going through all the proper hooks."
3747 (funcall *encoding-external-format-hook
* (or encoding
*default-encoding
*))))
3751 (with-upgradability ()
3752 (defvar *standard-readtable
* (with-standard-io-syntax *readtable
*)
3753 "The standard readtable, implementing the syntax specified by the CLHS.
3754 It must never be modified, though only good implementations will even enforce that.")
3756 (defmacro with-safe-io-syntax
((&key
(package :cl
)) &body body
)
3757 "Establish safe CL reader options around the evaluation of BODY"
3758 `(call-with-safe-io-syntax #'(lambda () (let ((*package
* (find-package ,package
))) ,@body
))))
3760 (defun call-with-safe-io-syntax (thunk &key
(package :cl
))
3761 (with-standard-io-syntax
3762 (let ((*package
* (find-package package
))
3763 (*read-default-float-format
* 'double-float
)
3764 (*print-readably
* nil
)
3768 (defun safe-read-from-string (string &key
(package :cl
) (eof-error-p t
) eof-value
(start 0) end preserve-whitespace
)
3769 "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
3770 (with-safe-io-syntax (:package package
)
3771 (read-from-string string eof-error-p eof-value
:start start
:end end
:preserve-whitespace preserve-whitespace
))))
3774 (with-upgradability ()
3775 (defun call-with-output-file (pathname thunk
3777 (element-type *default-stream-element-type
*)
3778 (external-format *utf-8-external-format
*)
3780 (if-does-not-exist :create
))
3781 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3782 Other keys are accepted but discarded."
3783 (with-open-file (s pathname
:direction
:output
3784 :element-type element-type
3785 :external-format external-format
3786 :if-exists if-exists
3787 :if-does-not-exist if-does-not-exist
)
3790 (defmacro with-output-file
((var pathname
&rest keys
3791 &key element-type external-format if-exists if-does-not-exist
)
3793 (declare (ignore element-type external-format if-exists if-does-not-exist
))
3794 `(call-with-output-file ,pathname
#'(lambda (,var
) ,@body
) ,@keys
))
3796 (defun call-with-output (output function
&key keys
)
3797 "Calls FUNCTION with an actual stream argument,
3798 behaving like FORMAT with respect to how stream designators are interpreted:
3799 If OUTPUT is a STREAM, use it as the stream.
3800 If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
3801 If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
3802 If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream.
3803 If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE
3804 -- this latter as an extension since ASDF 3.1.
3805 Otherwise, signal an error."
3808 (with-output-to-string (stream) (funcall function stream
)))
3810 (funcall function
*standard-output
*))
3812 (funcall function output
))
3814 (assert (fill-pointer output
))
3815 (with-output-to-string (stream output
) (funcall function stream
)))
3817 (apply 'call-with-output-file output function keys
))))
3819 (defmacro with-output
((output-var &optional
(value output-var
)) &body body
)
3820 "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
3821 as per FORMAT, and evaluate BODY within the scope of this binding."
3822 `(call-with-output ,value
#'(lambda (,output-var
) ,@body
)))
3824 (defun output-string (string &optional output
)
3825 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
3827 (with-output (output) (princ string output
))
3832 (with-upgradability ()
3833 (defun call-with-input-file (pathname thunk
3835 (element-type *default-stream-element-type
*)
3836 (external-format *utf-8-external-format
*)
3837 (if-does-not-exist :error
))
3838 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3839 Other keys are accepted but discarded."
3840 (with-open-file (s pathname
:direction
:input
3841 :element-type element-type
3842 :external-format external-format
3843 :if-does-not-exist if-does-not-exist
)
3846 (defmacro with-input-file
((var pathname
&rest keys
3847 &key element-type external-format if-does-not-exist
)
3849 (declare (ignore element-type external-format if-does-not-exist
))
3850 `(call-with-input-file ,pathname
#'(lambda (,var
) ,@body
) ,@keys
))
3852 (defun call-with-input (input function
&key keys
)
3853 "Calls FUNCTION with an actual stream argument, interpreting
3854 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
3855 and PATHNAME to FILE-STREAM.
3856 If INPUT is a STREAM, use it as the stream.
3857 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
3858 If INPUT is T, use *TERMINAL-IO* as the stream.
3859 If INPUT is a STRING, use it as a string-input-stream.
3860 If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
3861 -- the latter is an extension since ASDF 3.1.
3862 Otherwise, signal an error."
3864 (null (funcall function
*standard-input
*))
3865 ((eql t
) (funcall function
*terminal-io
*))
3866 (stream (funcall function input
))
3867 (string (with-input-from-string (stream input
) (funcall function stream
)))
3868 (pathname (apply 'call-with-input-file input function keys
))))
3870 (defmacro with-input
((input-var &optional
(value input-var
)) &body body
)
3871 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
3872 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
3873 `(call-with-input ,value
#'(lambda (,input-var
) ,@body
)))
3875 (defun input-string (&optional input
)
3876 "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
3880 (with-input (input) (funcall 'slurp-stream-string input
)))))
3883 (with-upgradability ()
3884 (defun null-device-pathname ()
3885 "Pathname to a bit bucket device that discards any information written to it
3886 and always returns EOF when read from"
3888 ((os-unix-p) #p
"/dev/null")
3889 ((os-windows-p) #p
"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
3890 (t (error "No /dev/null on your OS"))))
3891 (defun call-with-null-input (fun &rest keys
&key element-type external-format if-does-not-exist
)
3892 "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
3893 (declare (ignore element-type external-format if-does-not-exist
))
3894 (apply 'call-with-input-file
(null-device-pathname) fun keys
))
3895 (defmacro with-null-input
((var &rest keys
3896 &key element-type external-format if-does-not-exist
)
3898 (declare (ignore element-type external-format if-does-not-exist
))
3899 "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
3900 Pass keyword arguments to OPEN."
3901 `(call-with-null-input #'(lambda (,var
) ,@body
) ,@keys
))
3902 (defun call-with-null-output (fun
3903 &key
(element-type *default-stream-element-type
*)
3904 (external-format *utf-8-external-format
*)
3905 (if-exists :overwrite
)
3906 (if-does-not-exist :error
))
3907 "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
3908 (call-with-output-file
3909 (null-device-pathname) fun
3910 :element-type element-type
:external-format external-format
3911 :if-exists if-exists
:if-does-not-exist if-does-not-exist
))
3912 (defmacro with-null-output
((var &rest keys
3913 &key element-type external-format if-does-not-exist if-exists
)
3915 "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
3916 Pass keyword arguments to OPEN."
3917 (declare (ignore element-type external-format if-exists if-does-not-exist
))
3918 `(call-with-null-output #'(lambda (,var
) ,@body
) ,@keys
)))
3920 ;;; Ensure output buffers are flushed
3921 (with-upgradability ()
3922 (defun finish-outputs (&rest streams
)
3923 "Finish output on the main output streams as well as any specified one.
3924 Useful for portably flushing I/O before user input or program exit."
3925 ;; CCL notably buffers its stream output by default.
3926 (dolist (s (append streams
3927 (list *stdout
* *stderr
* *error-output
* *standard-output
* *trace-output
*
3928 *debug-io
* *terminal-io
* *query-io
*)))
3929 (ignore-errors (finish-output s
)))
3932 (defun format! (stream format
&rest args
)
3933 "Just like format, but call finish-outputs before and after the output."
3934 (finish-outputs stream
)
3935 (apply 'format stream format args
)
3936 (finish-outputs stream
))
3938 (defun safe-format! (stream format
&rest args
)
3939 "Variant of FORMAT that is safe against both
3940 dangerous syntax configuration and errors while printing."
3941 (with-safe-io-syntax ()
3942 (ignore-errors (apply 'format
! stream format args
))
3943 (finish-outputs stream
)))) ; just in case format failed
3946 ;;; Simple Whole-Stream processing
3947 (with-upgradability ()
3948 (defun copy-stream-to-stream (input output
&key element-type buffer-size linewise prefix
)
3949 "Copy the contents of the INPUT stream into the OUTPUT stream.
3950 If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
3951 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
3952 (with-open-stream (input input
)
3954 (loop* :for
(line eof
) = (multiple-value-list (read-line input nil nil
))
3956 (when prefix
(princ prefix output
))
3958 (unless eof
(terpri output
))
3959 (finish-output output
)
3960 (when eof
(return)))
3962 :with buffer-size
= (or buffer-size
8192)
3963 :with buffer
= (make-array (list buffer-size
) :element-type
(or element-type
'character
))
3964 :for end
= (read-sequence buffer input
)
3966 :do
(write-sequence buffer output
:end end
)
3967 (when (< end buffer-size
) (return))))))
3969 (defun concatenate-files (inputs output
)
3970 "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
3971 (with-open-file (o output
:element-type
'(unsigned-byte 8)
3972 :direction
:output
:if-exists
:rename-and-delete
)
3973 (dolist (input inputs
)
3974 (with-open-file (i input
:element-type
'(unsigned-byte 8)
3975 :direction
:input
:if-does-not-exist
:error
)
3976 (copy-stream-to-stream i o
:element-type
'(unsigned-byte 8))))))
3978 (defun copy-file (input output
)
3979 "Copy contents of the INPUT file to the OUTPUT file"
3980 ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
3982 (excl.osi
:copy-file input output
)
3984 (ext:copy-file input output
)
3986 (concatenate-files (list input
) output
))
3988 (defun slurp-stream-string (input &key
(element-type 'character
) stripped
)
3989 "Read the contents of the INPUT stream as a string"
3991 (with-open-stream (input input
)
3992 (with-output-to-string (output)
3993 (copy-stream-to-stream input output
:element-type element-type
)))))
3994 (if stripped
(stripln string
) string
)))
3996 (defun slurp-stream-lines (input &key count
)
3997 "Read the contents of the INPUT stream as a list of lines, return those lines.
3999 Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
4000 from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
4002 Read no more than COUNT lines."
4003 (check-type count
(or null integer
))
4004 (with-open-stream (input input
)
4005 (loop :for n
:from
0
4006 :for l
= (and (or (not count
) (< n count
))
4007 (read-line input nil nil
))
4008 ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
4009 :while l
:collect
(stripln l
))))
4011 (defun slurp-stream-line (input &key
(at 0))
4012 "Read the contents of the INPUT stream as a list of lines,
4013 then return the ACCESS-AT of that list of lines using the AT specifier.
4014 PATH defaults to 0, i.e. return the first line.
4015 PATH is typically an integer, or a list of an integer and a function.
4016 If PATH is NIL, it will return all the lines in the file.
4018 The stream will not be read beyond the Nth lines,
4019 where N is the index specified by path
4020 if path is either an integer or a list that starts with an integer."
4021 (access-at (slurp-stream-lines input
:count
(access-at-count at
)) at
))
4023 (defun slurp-stream-forms (input &key count
)
4024 "Read the contents of the INPUT stream as a list of forms,
4025 and return those forms.
4027 If COUNT is null, read to the end of the stream;
4028 if COUNT is an integer, stop after COUNT forms were read.
4030 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4031 (check-type count
(or null integer
))
4032 (loop :with eof
= '#:eof
4034 :for form
= (if (and count
(>= n count
))
4036 (read-preserving-whitespace input nil eof
))
4037 :until
(eq form eof
) :collect form
))
4039 (defun slurp-stream-form (input &key
(at 0))
4040 "Read the contents of the INPUT stream as a list of forms,
4041 then return the ACCESS-AT of these forms following the AT.
4042 AT defaults to 0, i.e. return the first form.
4043 AT is typically a list of integers.
4044 If AT is NIL, it will return all the forms in the file.
4046 The stream will not be read beyond the Nth form,
4047 where N is the index specified by path,
4048 if path is either an integer or a list that starts with an integer.
4050 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4051 (access-at (slurp-stream-forms input
:count
(access-at-count at
)) at
))
4053 (defun read-file-string (file &rest keys
)
4054 "Open FILE with option KEYS, read its contents as a string"
4055 (apply 'call-with-input-file file
'slurp-stream-string keys
))
4057 (defun read-file-lines (file &rest keys
)
4058 "Open FILE with option KEYS, read its contents as a list of lines
4059 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4060 (apply 'call-with-input-file file
'slurp-stream-lines keys
))
4062 (defun read-file-line (file &rest keys
&key
(at 0) &allow-other-keys
)
4063 "Open input FILE with option KEYS (except AT),
4064 and read its contents as per SLURP-STREAM-LINE with given AT specifier.
4065 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4066 (apply 'call-with-input-file file
4067 #'(lambda (input) (slurp-stream-line input
:at at
))
4068 (remove-plist-key :at keys
)))
4070 (defun read-file-forms (file &rest keys
&key count
&allow-other-keys
)
4071 "Open input FILE with option KEYS (except COUNT),
4072 and read its contents as per SLURP-STREAM-FORMS with given COUNT.
4073 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4074 (apply 'call-with-input-file file
4075 #'(lambda (input) (slurp-stream-forms input
:count count
))
4076 (remove-plist-key :count keys
)))
4078 (defun read-file-form (file &rest keys
&key
(at 0) &allow-other-keys
)
4079 "Open input FILE with option KEYS (except AT),
4080 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
4081 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4082 (apply 'call-with-input-file file
4083 #'(lambda (input) (slurp-stream-form input
:at at
))
4084 (remove-plist-key :at keys
)))
4086 (defun safe-read-file-line (pathname &rest keys
&key
(package :cl
) &allow-other-keys
)
4087 "Reads the specified line from the top of a file using a safe standardized syntax.
4088 Extracts the line using READ-FILE-LINE,
4089 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
4090 (with-safe-io-syntax (:package package
)
4091 (apply 'read-file-line pathname
(remove-plist-key :package keys
))))
4093 (defun safe-read-file-form (pathname &rest keys
&key
(package :cl
) &allow-other-keys
)
4094 "Reads the specified form from the top of a file using a safe standardized syntax.
4095 Extracts the form using READ-FILE-FORM,
4096 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
4097 (with-safe-io-syntax (:package package
)
4098 (apply 'read-file-form pathname
(remove-plist-key :package keys
))))
4100 (defun eval-input (input)
4101 "Portably read and evaluate forms from INPUT, return the last values."
4103 (loop :with results
:with eof
='#:eof
4104 :for form
= (read input nil eof
)
4105 :until
(eq form eof
)
4106 :do
(setf results
(multiple-value-list (eval form
)))
4107 :finally
(return (values-list results
)))))
4109 (defun eval-thunk (thunk)
4110 "Evaluate a THUNK of code:
4111 If a function, FUNCALL it without arguments.
4112 If a constant literal and not a sequence, return it.
4113 If a cons or a symbol, EVAL it.
4114 If a string, repeatedly read and evaluate from it, returning the last values."
4116 ((or boolean keyword number character pathname
) thunk
)
4117 ((or cons symbol
) (eval thunk
))
4118 (function (funcall thunk
))
4119 (string (eval-input thunk
))))
4121 (defun standard-eval-thunk (thunk &key
(package :cl
))
4122 "Like EVAL-THUNK, but in a more standardized evaluation context."
4123 ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
4125 (with-safe-io-syntax (:package package
)
4126 (let ((*read-eval
* t
))
4127 (eval-thunk thunk
))))))
4129 (with-upgradability ()
4130 (defun println (x &optional
(stream *standard-output
*))
4131 "Variant of PRINC that also calls TERPRI afterwards"
4132 (princ x stream
) (terpri stream
) (finish-output stream
) (values))
4134 (defun writeln (x &rest keys
&key
(stream *standard-output
*) &allow-other-keys
)
4135 "Variant of WRITE that also calls TERPRI afterwards"
4136 (apply 'write x keys
) (terpri stream
) (finish-output stream
) (values)))
4139 ;;; Using temporary files
4140 (with-upgradability ()
4141 (defun default-temporary-directory ()
4142 "Return a default directory to use for temporary files"
4145 (or (getenv-pathname "TMPDIR" :ensure-directory t
)
4146 (parse-native-namestring "/tmp/")))
4148 (getenv-pathname "TEMP" :ensure-directory t
))
4149 (t (subpathname (user-homedir-pathname) "tmp/"))))
4151 (defvar *temporary-directory
* nil
"User-configurable location for temporary files")
4153 (defun temporary-directory ()
4154 "Return a directory to use for temporary files"
4155 (or *temporary-directory
* (default-temporary-directory)))
4157 (defun setup-temporary-directory ()
4158 "Configure a default temporary directory to use."
4159 (setf *temporary-directory
* (default-temporary-directory))
4160 #+gcl
(setf system
::*tmp-dir
* *temporary-directory
*))
4162 (defun call-with-temporary-file
4164 (want-stream-p t
) (want-pathname-p t
) (direction :io
) keep after
4165 directory
(type "tmp" typep
) prefix
(suffix (when typep
"-tmp"))
4166 (element-type *default-stream-element-type
*)
4167 (external-format *utf-8-external-format
*))
4168 "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
4170 The temporary file's pathname will be based on concatenating
4171 PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
4172 and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
4173 and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
4174 within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
4176 The file will be open with specified DIRECTION (defaults to :IO),
4177 ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
4178 EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
4179 If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
4180 with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
4181 and stream will be closed after the THUNK exits (either normally or abnormally).
4182 If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
4183 THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
4184 Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
4185 If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
4186 Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
4187 #+xcl
(declare (ignorable typep
))
4188 (check-type direction
(member :output
:io
))
4189 (assert (or want-stream-p want-pathname-p
))
4191 :with prefix-pn
= (ensure-absolute-pathname
4193 (or (ensure-pathname
4198 #'temporary-directory
))
4199 :with prefix-nns
= (native-namestring prefix-pn
)
4200 :with results
= (progn (ensure-directories-exist prefix-pn
)
4202 :for counter
:from
(random (expt 36 #-gcl
8 #+gcl
5))
4203 :for pathname
= (parse-native-namestring
4204 (format nil
"~A~36R~@[~A~]~@[.~A~]"
4205 prefix-nns counter suffix
(unless (eq type
:unspecific
) type
)))
4207 ;; TODO: on Unix, do something about umask
4208 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
4209 ;; TODO: on Unix, use CFFI and mkstemp --
4210 ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
4211 ;; Can we at least design some hook?
4214 (ensure-directories-exist pathname
)
4215 (with-open-file (stream pathname
4216 :direction direction
4217 :element-type element-type
4218 :external-format external-format
4219 :if-exists nil
:if-does-not-exist
:create
)
4223 ;; Note: can't return directly from within with-open-file
4224 ;; or the non-local return causes the file creation to be undone.
4225 (setf results
(multiple-value-list
4227 (funcall thunk stream pathname
)
4228 (funcall thunk stream
)))))))
4231 (after (return (call-function after okp
)))
4232 ((and want-pathname-p
(not want-stream-p
)) (return (call-function thunk okp
)))
4233 (t (return (values-list results
)))))
4234 (when (and okp
(not (call-function keep
)))
4235 (ignore-errors (delete-file-if-exists okp
))))))
4237 (defmacro with-temporary-file
((&key
(stream (gensym "STREAM") streamp
)
4238 (pathname (gensym "PATHNAME") pathnamep
)
4239 directory prefix suffix type
4240 keep direction element-type external-format
)
4242 "Evaluate BODY where the symbols specified by keyword arguments
4243 STREAM and PATHNAME (if respectively specified) are bound corresponding
4244 to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
4245 At least one of STREAM or PATHNAME must be specified.
4246 If the STREAM is not specified, it will be closed before the BODY is evaluated.
4247 If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
4248 separates forms run before and after the stream is closed.
4249 The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
4250 Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
4251 (check-type stream symbol
)
4252 (check-type pathname symbol
)
4253 (assert (or streamp pathnamep
))
4254 (let* ((afterp (position :close-stream body
))
4255 (before (if afterp
(subseq body
0 afterp
) body
))
4256 (after (when afterp
(subseq body
(1+ afterp
))))
4257 (beforef (gensym "BEFORE"))
4258 (afterf (gensym "AFTER")))
4259 `(flet (,@(when before
4260 `((,beforef
(,@(when streamp
`(,stream
)) ,@(when pathnamep
`(,pathname
)))
4261 ,@(when after
`((declare (ignorable ,pathname
))))
4265 `((,afterf
(,pathname
) ,@after
))))
4266 #-gcl
(declare (dynamic-extent ,@(when before
`(#',beforef
)) ,@(when after
`(#',afterf
))))
4267 (call-with-temporary-file
4268 ,(when before
`#',beforef
)
4269 :want-stream-p
,streamp
4270 :want-pathname-p
,pathnamep
4271 ,@(when direction
`(:direction
,direction
))
4272 ,@(when directory
`(:directory
,directory
))
4273 ,@(when prefix
`(:prefix
,prefix
))
4274 ,@(when suffix
`(:suffix
,suffix
))
4275 ,@(when type
`(:type
,type
))
4276 ,@(when keep
`(:keep
,keep
))
4277 ,@(when after
`(:after
#',afterf
))
4278 ,@(when element-type
`(:element-type
,element-type
))
4279 ,@(when external-format
`(:external-format
,external-format
))))))
4281 (defun get-temporary-file (&key directory prefix suffix type
)
4282 (with-temporary-file (:pathname pn
:keep t
4283 :directory directory
:prefix prefix
:suffix suffix
:type type
)
4286 ;; Temporary pathnames in simple cases where no contention is assumed
4287 (defun add-pathname-suffix (pathname suffix
&rest keys
)
4288 "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
4289 Further KEYS can be passed to MAKE-PATHNAME."
4290 (apply 'make-pathname
:name
(strcat (pathname-name pathname
) suffix
)
4291 :defaults pathname keys
))
4293 (defun tmpize-pathname (x)
4294 "Return a new pathname modified from X by adding a trivial random suffix.
4295 A new empty file with said temporary pathname is created, to ensure there is no
4296 clash with any concurrent process attempting the same thing."
4297 (let* ((px (ensure-pathname x
:ensure-physical t
))
4298 (prefix (if-let (n (pathname-name px
)) (strcat n
"-tmp") "tmp"))
4299 (directory (pathname-directory-pathname px
)))
4300 (get-temporary-file :directory directory
:prefix prefix
:type
(pathname-type px
))))
4302 (defun call-with-staging-pathname (pathname fun
)
4303 "Calls FUN with a staging pathname, and atomically
4304 renames the staging pathname to the PATHNAME in the end.
4305 NB: this protects only against failure of the program, not against concurrent attempts.
4306 For the latter case, we ought pick a random suffix and atomically open it."
4307 (let* ((pathname (pathname pathname
))
4308 (staging (tmpize-pathname pathname
)))
4310 (multiple-value-prog1
4311 (funcall fun staging
)
4312 (rename-file-overwriting-target staging pathname
))
4313 (delete-file-if-exists staging
))))
4315 (defmacro with-staging-pathname
((pathname-var &optional
(pathname-value pathname-var
)) &body body
)
4316 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
4317 `(call-with-staging-pathname ,pathname-value
#'(lambda (,pathname-var
) ,@body
))))
4319 (with-upgradability ()
4320 (defun file-stream-p (stream)
4321 (typep stream
'file-stream
))
4322 (defun file-or-synonym-stream-p (stream)
4323 (or (file-stream-p stream
)
4324 (and (typep stream
'synonym-stream
)
4325 (file-or-synonym-stream-p
4326 (symbol-value (synonym-stream-symbol stream
)))))))
4327 ;;;; -------------------------------------------------------------------------
4328 ;;;; Starting, Stopping, Dumping a Lisp image
4330 (uiop/package
:define-package
:uiop
/image
4331 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/pathname
:uiop
/stream
:uiop
/os
)
4333 #:*image-dumped-p
* #:raw-command-line-arguments
#:*command-line-arguments
*
4334 #:command-line-arguments
#:raw-command-line-arguments
#:setup-command-line-arguments
#:argv0
4335 #:*lisp-interaction
*
4336 #:fatal-condition
#:fatal-condition-p
4337 #:handle-fatal-condition
4338 #:call-with-fatal-condition-handler
#:with-fatal-condition-handler
4339 #:*image-restore-hook
* #:*image-prelude
* #:*image-entry-point
*
4340 #:*image-postlude
* #:*image-dump-hook
*
4341 #:quit
#:die
#:raw-print-backtrace
#:print-backtrace
#:print-condition-backtrace
4342 #:shell-boolean-exit
4343 #:register-image-restore-hook
#:register-image-dump-hook
4344 #:call-image-restore-hook
#:call-image-dump-hook
4345 #:restore-image
#:dump-image
#:create-image
4347 (in-package :uiop
/image
)
4349 (with-upgradability ()
4350 (defvar *lisp-interaction
* t
4351 "Is this an interactive Lisp environment, or is it batch processing?")
4353 (defvar *command-line-arguments
* nil
4354 "Command-line arguments")
4356 (defvar *image-dumped-p
* nil
; may matter as to how to get to command-line-arguments
4357 "Is this a dumped image? As a standalone executable?")
4359 (defvar *image-restore-hook
* nil
4360 "Functions to call (in reverse order) when the image is restored")
4362 (defvar *image-restored-p
* nil
4363 "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
4365 (defvar *image-prelude
* nil
4366 "a form to evaluate, or string containing forms to read and evaluate
4367 when the image is restarted, but before the entry point is called.")
4369 (defvar *image-entry-point
* nil
4370 "a function with which to restart the dumped image when execution is restored from it.")
4372 (defvar *image-postlude
* nil
4373 "a form to evaluate, or string containing forms to read and evaluate
4374 before the image dump hooks are called and before the image is dumped.")
4376 (defvar *image-dump-hook
* nil
4377 "Functions to call (in order) when before an image is dumped"))
4379 (eval-when (#-lispworks
:compile-toplevel
:load-toplevel
:execute
)
4380 (deftype fatal-condition
()
4381 `(and serious-condition
#+clozure
(not ccl
:process-reset
))))
4383 ;;; Exiting properly or im-
4384 (with-upgradability ()
4385 (defun quit (&optional
(code 0) (finish-output t
))
4386 "Quits from the Lisp world, with the given exit status if provided.
4387 This is designed to abstract away the implementation specific quit forms."
4388 (when finish-output
;; essential, for ClozureCL, and for standard compliance.
4390 #+(or abcl xcl
) (ext:quit
:status code
)
4391 #+allegro
(excl:exit code
:quiet t
)
4392 #+(or clasp ecl
) (si:quit code
)
4393 #+clisp
(ext:quit code
)
4394 #+clozure
(ccl:quit code
)
4395 #+cormanlisp
(win32:exitprocess code
)
4396 #+(or cmucl scl
) (unix:unix-exit code
)
4397 #+gcl
(system:quit code
)
4398 #+genera
(error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code
)
4399 #+lispworks
(lispworks:quit
:status code
:confirm nil
:return nil
:ignore-errors-p t
)
4400 #+mcl
(progn code
(ccl:quit
)) ;; or should we use FFI to call libc's exit(3) ?
4401 #+mkcl
(mk-ext:quit
:exit-code code
)
4402 #+sbcl
#.
(let ((exit (find-symbol* :exit
:sb-ext nil
))
4403 (quit (find-symbol* :quit
:sb-ext nil
)))
4405 (exit `(,exit
:code code
:abort
(not finish-output
)))
4406 (quit `(,quit
:unix-status code
:recklessly-p
(not finish-output
)))))
4407 #-
(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
4408 (not-implemented-error 'quit
"(called with exit code ~S)" code
))
4410 (defun die (code format
&rest arguments
)
4411 "Die in error with some error message"
4412 (with-safe-io-syntax ()
4414 (format! *stderr
* "~&~?~&" format arguments
)))
4417 (defun raw-print-backtrace (&key
(stream *debug-io
*) count condition
)
4418 "Print a backtrace, directly accessing the implementation"
4419 (declare (ignorable stream count condition
))
4421 (loop :for i
:from
0
4422 :for frame
:in
(sys:backtrace
(or count most-positive-fixnum
)) :do
4423 (safe-format! stream
"~&~D: ~A~%" i frame
))
4425 (let ((*terminal-io
* stream
)
4426 (*standard-output
* stream
)
4427 (tpl:*zoom-print-circle
* *print-circle
*)
4428 (tpl:*zoom-print-level
* *print-level
*)
4429 (tpl:*zoom-print-length
* *print-length
*))
4430 (tpl:do-command
"zoom"
4431 :from-read-eval-print-loop nil
4434 #+(or clasp ecl mkcl
)
4435 (let* ((top (si:ihs-top
))
4436 (repeats (if count
(min top count
) top
))
4437 (backtrace (loop :for ihs
:from
0 :below top
4438 :collect
(list (si::ihs-fun ihs
)
4439 (si::ihs-env ihs
)))))
4440 (loop :for i
:from
0 :below repeats
4441 :for frame
:in
(nreverse backtrace
) :do
4442 (safe-format! stream
"~&~D: ~S~%" i frame
)))
4444 (system::print-backtrace
:out stream
:limit count
)
4446 (let ((*debug-io
* stream
))
4447 #+clozure
(ccl:print-call-history
:count count
:start-frame-number
1)
4448 #+mcl
(ccl:print-call-history
:detailed-p nil
)
4449 (finish-output stream
))
4451 (let ((debug:*debug-print-level
* *print-level
*)
4452 (debug:*debug-print-length
* *print-length
*))
4453 (debug:backtrace
(or count most-positive-fixnum
) stream
))
4455 (let ((*debug-io
* stream
))
4457 (with-safe-io-syntax ()
4459 (conditions::condition-backtrace condition
)
4460 (system::simple-backtrace
)))))
4462 (let ((dbg::*debugger-stack
*
4463 (dbg::grab-stack nil
:how-many
(or count most-positive-fixnum
)))
4465 (dbg:*debug-print-level
* *print-level
*)
4466 (dbg:*debug-print-length
* *print-length
*))
4467 (dbg:bug-backtrace nil
))
4469 (sb-debug:print-backtrace
:stream stream
:count
(or count most-positive-fixnum
))
4471 (loop :for i
:from
0 :below
(or count most-positive-fixnum
)
4472 :for frame
:in
(extensions:backtrace-as-list
) :do
4473 (safe-format! stream
"~&~D: ~S~%" i frame
)))
4475 (defun print-backtrace (&rest keys
&key stream count condition
)
4477 (declare (ignore stream count condition
))
4478 (with-safe-io-syntax (:package
:cl
)
4479 (let ((*print-readably
* nil
)
4481 (*print-miser-width
* 75)
4482 (*print-length
* nil
)
4485 (ignore-errors (apply 'raw-print-backtrace keys
)))))
4487 (defun print-condition-backtrace (condition &key
(stream *stderr
*) count
)
4488 "Print a condition after a backtrace triggered by that condition"
4489 ;; We print the condition *after* the backtrace,
4490 ;; for the sake of who sees the backtrace at a terminal.
4491 ;; It is up to the caller to print the condition *before*, with some context.
4492 (print-backtrace :stream stream
:count count
:condition condition
)
4494 (safe-format! stream
"~&Above backtrace due to this condition:~%~A~&"
4497 (defun fatal-condition-p (condition)
4498 "Is the CONDITION fatal?"
4499 (typep condition
'fatal-condition
))
4501 (defun handle-fatal-condition (condition)
4502 "Handle a fatal CONDITION:
4503 depending on whether *LISP-INTERACTION* is set, enter debugger or die"
4506 (invoke-debugger condition
))
4508 (safe-format! *stderr
* "~&Fatal condition:~%~A~%" condition
)
4509 (print-condition-backtrace condition
:stream
*stderr
*)
4510 (die 99 "~A" condition
))))
4512 (defun call-with-fatal-condition-handler (thunk)
4513 "Call THUNK in a context where fatal conditions are appropriately handled"
4514 (handler-bind ((fatal-condition #'handle-fatal-condition
))
4517 (defmacro with-fatal-condition-handler
((&optional
) &body body
)
4518 "Execute BODY in a context where fatal conditions are appropriately handled"
4519 `(call-with-fatal-condition-handler #'(lambda () ,@body
)))
4521 (defun shell-boolean-exit (x)
4522 "Quit with a return code that is 0 iff argument X is true"
4526 ;;; Using image hooks
4527 (with-upgradability ()
4528 (defun register-image-restore-hook (hook &optional
(call-now-p t
))
4529 "Regiter a hook function to be run when restoring a dumped image"
4530 (register-hook-function '*image-restore-hook
* hook call-now-p
))
4532 (defun register-image-dump-hook (hook &optional
(call-now-p nil
))
4533 "Register a the hook function to be run before to dump an image"
4534 (register-hook-function '*image-dump-hook
* hook call-now-p
))
4536 (defun call-image-restore-hook ()
4537 "Call the hook functions registered to be run when restoring a dumped image"
4538 (call-functions (reverse *image-restore-hook
*)))
4540 (defun call-image-dump-hook ()
4541 "Call the hook functions registered to be run before to dump an image"
4542 (call-functions *image-dump-hook
*)))
4545 ;;; Proper command-line arguments
4546 (with-upgradability ()
4547 (defun raw-command-line-arguments ()
4548 "Find what the actual command line for this process was."
4549 #+abcl ext
:*command-line-argument-list
* ; Use 1.0.0 or later!
4550 #+allegro
(sys:command-line-arguments
) ; default: :application t
4551 #+(or clasp ecl
) (loop :for i
:from
0 :below
(si:argc
) :collect
(si:argv i
))
4552 #+clisp
(coerce (ext:argv
) 'list
)
4553 #+clozure ccl
:*command-line-argument-list
*
4554 #+(or cmucl scl
) extensions
:*command-line-strings
*
4555 #+gcl si
:*command-args
*
4556 #+(or genera mcl
) nil
4557 #+lispworks sys
:*line-arguments-list
*
4558 #+mkcl
(loop :for i
:from
0 :below
(mkcl:argc
) :collect
(mkcl:argv i
))
4559 #+sbcl sb-ext
:*posix-argv
*
4561 #-
(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
4562 (not-implemented-error 'raw-command-line-arguments
))
4564 (defun command-line-arguments (&optional
(arguments (raw-command-line-arguments)))
4565 "Extract user arguments from command-line invocation of current process.
4566 Assume the calling conventions of a generated script that uses --
4567 if we are not called from a directly executable image."
4569 #+abcl
(return arguments
)
4570 ;; SBCL and Allegro already separate user arguments from implementation arguments.
4572 (unless (eq *image-dumped-p
* :executable
)
4573 ;; LispWorks command-line processing isn't transparent to the user
4574 ;; unless you create a standalone executable; in that case,
4575 ;; we rely on cl-launch or some other script to set the arguments for us.
4576 #+lispworks
(return *command-line-arguments
*)
4577 ;; On other implementations, on non-standalone executables,
4578 ;; we trust cl-launch or whichever script starts the program
4579 ;; to use -- as a delimiter between implementation arguments and user arguments.
4580 #-lispworks
(setf arguments
(member "--" arguments
:test
'string-equal
)))
4584 "On supported implementations (most that matter), or when invoked by a proper wrapper script,
4585 return a string that for the name with which the program was invoked, i.e. argv[0] in C.
4586 Otherwise, return NIL."
4588 ((eq *image-dumped-p
* :executable
) ; yes, this ARGV0 is our argv0 !
4589 ;; NB: not currently available on ABCL, Corman, Genera, MCL
4590 (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl
)
4591 (first (raw-command-line-arguments))
4592 #+(or clasp ecl
) (si:argv
0) #+mkcl
(mkcl:argv
0)))
4593 (t ;; argv[0] is the name of the interpreter.
4594 ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
4595 (getenvp "__CL_ARGV0"))))
4597 (defun setup-command-line-arguments ()
4598 (setf *command-line-arguments
* (command-line-arguments)))
4600 (defun restore-image (&key
4601 (lisp-interaction *lisp-interaction
*)
4602 (restore-hook *image-restore-hook
*)
4603 (prelude *image-prelude
*)
4604 (entry-point *image-entry-point
*)
4605 (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
4606 "From a freshly restarted Lisp image, restore the saved Lisp environment
4607 by setting appropriate variables, running various hooks, and calling any specified entry point.
4609 If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
4610 call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
4611 immediately to the surrounding restore process if allowed to continue.
4613 Then, comes the restore process itself:
4614 First, call each function in the RESTORE-HOOK,
4615 in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
4616 Second, evaluate the prelude, which is often Lisp text that is read,
4618 Third, call the ENTRY-POINT function, if any is specified, with no argument.
4620 The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
4621 any unhandled error leads to a backtrace and an exit with an error status.
4622 If LISP-INTERACTION is NIL, the process also exits when no error occurs:
4623 if neither restart nor entry function is provided, the program will exit with status 0 (success);
4624 if a function was provided, the program will exit after the function returns (if it returns),
4625 with status 0 if and only if the primary return value of result is generalized boolean true,
4626 and with status 1 if this value is NIL.
4628 If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
4629 of the function will be returned rather than interpreted as a boolean designating an exit code."
4630 (when *image-restored-p
*
4631 (if if-already-restored
4632 (call-function if-already-restored
"Image already ~:[being ~;~]restored"
4633 (eq *image-restored-p
* t
))
4634 (return-from restore-image
)))
4635 (with-fatal-condition-handler ()
4636 (setf *lisp-interaction
* lisp-interaction
)
4637 (setf *image-restore-hook
* restore-hook
)
4638 (setf *image-prelude
* prelude
)
4639 (setf *image-restored-p
* :in-progress
)
4640 (call-image-restore-hook)
4641 (standard-eval-thunk prelude
)
4642 (setf *image-restored-p
* t
)
4643 (let ((results (multiple-value-list
4645 (call-function entry-point
)
4647 (if lisp-interaction
4648 (values-list results
)
4649 (shell-boolean-exit (first results
)))))))
4652 ;;; Dumping an image
4654 (with-upgradability ()
4655 (defun dump-image (filename &key output-name executable
4656 (postlude *image-postlude
*)
4657 (dump-hook *image-dump-hook
*)
4658 #+clozure prepend-symbols
#+clozure
(purify t
)
4660 #+(and sbcl os-windows
) application-type
)
4661 "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
4663 First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
4664 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK.
4666 If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
4668 Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
4669 or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
4670 ;; Note: at least SBCL saves only global values of variables in the heap image,
4671 ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
4672 (declare (ignorable filename output-name executable
))
4673 (setf *image-dumped-p
* (if executable
:executable t
))
4674 (setf *image-restored-p
* :in-regress
)
4675 (setf *image-postlude
* postlude
)
4676 (standard-eval-thunk *image-postlude
*)
4677 (setf *image-dump-hook
* dump-hook
)
4678 (call-image-dump-hook)
4679 (setf *image-restored-p
* nil
)
4680 #-
(or clisp clozure
(and cmucl executable
) lispworks sbcl scl
)
4682 (not-implemented-error 'dump-image
"dumping an executable"))
4685 (sys:resize-areas
:global-gc t
:pack-heap t
:sift-old-areas t
:tenure t
) ; :new 5000000
4686 (excl:dumplisp
:name filename
:suppress-allegro-cl-banner t
))
4688 (apply #'ext
:saveinitmem filename
4690 :start-package
*package
*
4691 :keep-global-handlers nil
4692 :executable
(if executable
0 t
) ;--- requires clisp 2.48 or later, still catches --clisp-x
4695 ;; :parse-options nil ;--- requires a non-standard patch to clisp.
4696 :norc t
:script nil
:init-function
#'restore-image
)))
4698 (flet ((dump (prepend-kernel)
4699 (ccl:save-application filename
:prepend-kernel prepend-kernel
:purify purify
4700 :toplevel-function
(when executable
#'restore-image
))))
4701 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
4703 (with-temporary-file (:prefix
"ccl-symbols-" :direction
:output
:pathname path
)
4705 (funcall (fdefinition 'ccl
::write-elf-symbols-to-file
) path
)
4711 (setf ext
:*batch-mode
* nil
)
4712 (setf ext
::*gc-run-time
* 0)
4713 (apply 'ext
:save-lisp filename
4714 :allow-other-keys t
;; hush SCL and old versions of CMUCL
4715 #+(and cmucl executable
) :executable
#+(and cmucl executable
) t
4716 (when executable
'(:init-function restore-image
:process-command-line nil
4717 :quiet t
:load-init-file nil
:site-init nil
))))
4720 (si::set-hole-size
500) (si::gbc nil
) (si::sgc-on t
)
4721 (si::save-system filename
))
4724 (lispworks:deliver
'restore-image filename
0 :interface nil
)
4725 (hcl:save-image filename
:environment nil
))
4728 ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
4729 (setf sb-ext
::*gc-run-time
* 0)
4730 (apply 'sb-ext
:save-lisp-and-die filename
4731 :executable t
;--- always include the runtime that goes with the core
4733 (when compression
(list :compression compression
))
4734 ;;--- only save runtime-options for standalone executables
4735 (when executable
(list :toplevel
#'restore-image
:save-runtime-options t
))
4736 #+(and sbcl os-windows
) ;; passing :application-type :gui will disable the console window.
4737 ;; the default is :console - only works with SBCL 1.1.15 or later.
4738 (when application-type
(list :application-type application-type
)))))
4739 #-
(or allegro clisp clozure cmucl gcl lispworks sbcl scl
)
4740 (not-implemented-error 'dump-image
))
4742 (defun create-image (destination lisp-object-files
4743 &key kind output-name prologue-code epilogue-code extra-object-files
4744 (prelude () preludep
) (postlude () postludep
)
4745 (entry-point () entry-point-p
) build-args no-uiop
)
4746 (declare (ignorable destination lisp-object-files extra-object-files kind output-name
4747 prologue-code epilogue-code prelude preludep postlude postludep
4748 entry-point entry-point-p build-args no-uiop
))
4749 "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
4750 ;; Is it meaningful to run these in the current environment?
4751 ;; only if we also track the object files that constitute the "current" image,
4752 ;; and otherwise simulate dump-image, including quitting at the end.
4753 #-
(or clasp ecl mkcl
) (not-implemented-error 'create-image
)
4754 #+(or clasp ecl mkcl
)
4755 (let ((epilogue-code
4760 (when epilogue-code
`(,epilogue-code
))
4761 (when postludep
`((setf *image-postlude
* ',postlude
)))
4762 (when preludep
`((setf *image-prelude
* ',prelude
)))
4763 (when entry-point-p
`((setf *image-entry-point
* ',entry-point
)))
4766 (setf kind
:program
) ;; to ECL, it's just another program.
4767 `((setf *image-dumped-p
* t
)
4768 (si::top-level
#+(or clasp ecl
) t
) (quit)))
4770 `((setf *image-dumped-p
* :executable
)
4772 (restore-image))))))))
4773 (when forms
`(progn ,@forms
))))))
4774 #+(or clasp ecl mkcl
)
4775 (check-type kind
(member :dll
:shared-library
:lib
:static-library
4776 :fasl
:fasb
:program
))
4777 (apply #+clasp
'cmp
:builder
#+clasp kind
4780 ((:dll
:shared-library
)
4781 #+ecl
'c
::build-shared-library
#+mkcl
'compiler
:build-shared-library
)
4782 ((:lib
:static-library
)
4783 #+ecl
'c
::build-static-library
#+mkcl
'compiler
:build-static-library
)
4784 ((:fasl
#+ecl
:fasb
)
4785 #+ecl
'c
::build-fasl
#+mkcl
'compiler
:build-fasl
)
4786 #+mkcl
((:fasb
) 'compiler
:build-bundle
)
4788 #+ecl
'c
::build-program
#+mkcl
'compiler
:build-program
))
4789 (pathname destination
)
4790 #+(or clasp ecl
) :lisp-files
#+mkcl
:lisp-object-files
4791 (append lisp-object-files
#+(or clasp ecl
) extra-object-files
)
4793 #+ecl
(getf build-args
:init-name
)
4795 (when prologue-code
`(:prologue-code
,prologue-code
))
4796 (when epilogue-code
`(:epilogue-code
,epilogue-code
))
4797 #+mkcl
(when extra-object-files
`(:object-files
,extra-object-files
))
4801 ;;; Some universal image restore hooks
4802 (with-upgradability ()
4803 (map () 'register-image-restore-hook
4804 '(setup-stdin setup-stdout setup-stderr
4805 setup-command-line-arguments setup-temporary-directory
4807 ;;;; -------------------------------------------------------------------------
4808 ;;;; Support to build (compile and load) Lisp files
4810 (uiop/package
:define-package
:uiop
/lisp-build
4811 (:nicknames
:asdf
/lisp-build
) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp
4812 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
4813 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
)
4816 #:*compile-file-warnings-behaviour
* #:*compile-file-failure-behaviour
*
4817 #:*output-translation-function
*
4818 #:*optimization-settings
* #:*previous-optimization-settings
*
4819 #:*base-build-directory
*
4820 #:compile-condition
#:compile-file-error
#:compile-warned-error
#:compile-failed-error
4821 #:compile-warned-warning
#:compile-failed-warning
4822 #:check-lisp-compile-results
#:check-lisp-compile-warnings
4823 #:*uninteresting-conditions
* #:*usual-uninteresting-conditions
*
4824 #:*uninteresting-compiler-conditions
* #:*uninteresting-loader-conditions
*
4826 #+sbcl
#:sb-grovel-unknown-constant-condition
4827 ;; Functions & Macros
4828 #:get-optimization-settings
#:proclaim-optimization-settings
#:with-optimization-settings
4829 #:call-with-muffled-compiler-conditions
#:with-muffled-compiler-conditions
4830 #:call-with-muffled-loader-conditions
#:with-muffled-loader-conditions
4831 #:reify-simple-sexp
#:unreify-simple-sexp
4832 #:reify-deferred-warnings
#:unreify-deferred-warnings
4833 #:reset-deferred-warnings
#:save-deferred-warnings
#:check-deferred-warnings
4834 #:with-saved-deferred-warnings
#:warnings-file-p
#:warnings-file-type
#:*warnings-file-type
*
4835 #:enable-deferred-warnings-check
#:disable-deferred-warnings-check
4836 #:current-lisp-file-pathname
#:load-pathname
4837 #:lispize-pathname
#:compile-file-type
#:call-around-hook
4838 #:compile-file
* #:compile-file-pathname
* #:*compile-check
*
4839 #:load
* #:load-from-string
#:combine-fasls
)
4840 (:intern
#:defaults
#:failure-p
#:warnings-p
#:s
#:y
#:body
))
4841 (in-package :uiop
/lisp-build
)
4843 (with-upgradability ()
4844 (defvar *compile-file-warnings-behaviour
*
4845 (or #+clisp
:ignore
:warn
)
4846 "How should ASDF react if it encounters a warning when compiling a file?
4847 Valid values are :error, :warn, and :ignore.")
4849 (defvar *compile-file-failure-behaviour
*
4850 (or #+(or mkcl sbcl
) :error
#+clisp
:ignore
:warn
)
4851 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
4852 when compiling a file, which includes any non-style-warning warning.
4853 Valid values are :error, :warn, and :ignore.
4854 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
4856 (defvar *base-build-directory
* nil
4857 "When set to a non-null value, it should be an absolute directory pathname,
4858 which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
4859 what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
4860 This can help you produce more deterministic output for FASLs."))
4862 ;;; Optimization settings
4863 (with-upgradability ()
4864 (defvar *optimization-settings
* nil
4865 "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
4866 (defvar *previous-optimization-settings
* nil
4867 "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
4868 (defparameter +optimization-variables
+
4869 ;; TODO: allegro genera corman mcl
4870 (or #+(or abcl xcl
) '(system::*speed
* system
::*space
* system
::*safety
* system
::*debug
*)
4871 #+clisp
'() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
4872 #+clozure
'(ccl::*nx-speed
* ccl
::*nx-space
* ccl
::*nx-safety
*
4873 ccl
::*nx-debug
* ccl
::*nx-cspeed
*)
4874 #+(or cmucl scl
) '(c::*default-cookie
*)
4876 #+ecl
(unless (use-ecl-byte-compiler-p) '(c::*speed
* c
::*space
* c
::*safety
* c
::*debug
*))
4877 #+gcl
'(compiler::*speed
* compiler
::*space
* compiler
::*compiler-new-safety
* compiler
::*debug
*)
4878 #+lispworks
'(compiler::*optimization-level
*)
4879 #+mkcl
'(si::*speed
* si
::*space
* si
::*safety
* si
::*debug
*)
4880 #+sbcl
'(sb-c::*policy
*)))
4881 (defun get-optimization-settings ()
4882 "Get current compiler optimization settings, ready to PROCLAIM again"
4883 #-
(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl
)
4884 (warn "~S does not support ~S. Please help me fix that."
4885 'get-optimization-settings
(implementation-type))
4886 #+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl
)
4887 (let ((settings '(speed space safety debug compilation-speed
#+(or cmucl scl
) c
::brevity
)))
4888 #.
`(loop #+(or allegro clozure
)
4889 ,@'(:with info
= #+allegro
(sys:declaration-information
'optimize
)
4890 #+clozure
(ccl:declaration-information
'optimize nil
))
4892 ,@(or #+(or abcl clasp ecl gcl mkcl xcl
) '(:for v
:in
+optimization-variables
+))
4893 :for y
= (or #+(or allegro clozure
) (second (assoc x info
)) ; normalize order
4894 #+clisp
(gethash x system
::*optimize
* 1)
4895 #+(or abcl clasp ecl mkcl xcl
) (symbol-value v
)
4896 #+(or cmucl scl
) (slot-value c
::*default-cookie
*
4897 (case x
(compilation-speed 'c
::cspeed
)
4899 #+lispworks
(slot-value compiler
::*optimization-level
* x
)
4900 #+sbcl
(sb-c::policy-quality sb-c
::*policy
* x
))
4901 :when y
:collect
(list x y
))))
4902 (defun proclaim-optimization-settings ()
4903 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
4904 (proclaim `(optimize ,@*optimization-settings
*))
4905 (let ((settings (get-optimization-settings)))
4906 (unless (equal *previous-optimization-settings
* settings
)
4907 (setf *previous-optimization-settings
* settings
))))
4908 (defmacro with-optimization-settings
((&optional
(settings *optimization-settings
*)) &body body
)
4909 #+(or allegro clisp
)
4910 (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
4911 `(let ((,previous-settings
(get-optimization-settings)))
4912 ,@(when settings
`((proclaim `(optimize ,@,settings
))))
4913 (unwind-protect (progn ,@body
)
4914 (proclaim `(optimize ,@,previous-settings
)))))
4915 #-
(or allegro clisp
)
4916 `(let ,(loop :for v
:in
+optimization-variables
+ :collect
`(,v
,v
))
4917 ,@(when settings
`((proclaim `(optimize ,@,settings
))))
4921 ;;; Condition control
4922 (with-upgradability ()
4925 (defun sb-grovel-unknown-constant-condition-p (c)
4926 "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
4927 (and (typep c
'sb-int
:simple-style-warning
)
4929 "Couldn't grovel for "
4930 (simple-condition-format-control c
)
4931 " (unknown to the C compiler).")))
4932 (deftype sb-grovel-unknown-constant-condition
()
4933 '(and style-warning
(satisfies sb-grovel-unknown-constant-condition-p
))))
4935 (defvar *usual-uninteresting-conditions
*
4937 ;;#+clozure '(ccl:compiler-warning)
4938 #+cmucl
'("Deleting unreachable code.")
4939 #+lispworks
'("~S being redefined in ~A (previously in ~A)."
4940 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
4942 '(sb-c::simple-compiler-note
4943 "&OPTIONAL and &KEY found in the same lambda list: ~S"
4944 #+sb-eval sb-kernel
:lexical-environment-too-complex
4945 sb-kernel
:undefined-alien-style-warning
4946 sb-grovel-unknown-constant-condition
; defined above.
4947 sb-ext
:implicit-generic-function-warning
;; Controversial.
4948 sb-int
:package-at-variance
4949 sb-kernel
:uninteresting-redefinition
4950 ;; BEWARE: the below four are controversial to include here.
4951 sb-kernel
:redefinition-with-defun
4952 sb-kernel
:redefinition-with-defgeneric
4953 sb-kernel
:redefinition-with-defmethod
4954 sb-kernel
::redefinition-with-defmacro
) ; not exported by old SBCLs
4955 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
4956 "A suggested value to which to set or bind *uninteresting-conditions*.")
4958 (defvar *uninteresting-conditions
* '()
4959 "Conditions that may be skipped while compiling or loading Lisp code.")
4960 (defvar *uninteresting-compiler-conditions
* '()
4961 "Additional conditions that may be skipped while compiling Lisp code.")
4962 (defvar *uninteresting-loader-conditions
*
4964 '("Overwriting already existing readtable ~S." ;; from named-readtables
4965 #(#:finalizers-off-warning
:asdf-finalizers
)) ;; from asdf-finalizers
4966 #+clisp
'(clos::simple-gf-replacing-method-warning
))
4967 "Additional conditions that may be skipped while loading Lisp code."))
4969 ;;;; ----- Filtering conditions while building -----
4970 (with-upgradability ()
4971 (defun call-with-muffled-compiler-conditions (thunk)
4972 "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
4973 (call-with-muffled-conditions
4974 thunk
(append *uninteresting-conditions
* *uninteresting-compiler-conditions
*)))
4975 (defmacro with-muffled-compiler-conditions
((&optional
) &body body
)
4976 "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
4977 `(call-with-muffled-compiler-conditions #'(lambda () ,@body
)))
4978 (defun call-with-muffled-loader-conditions (thunk)
4979 "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
4980 (call-with-muffled-conditions
4981 thunk
(append *uninteresting-conditions
* *uninteresting-loader-conditions
*)))
4982 (defmacro with-muffled-loader-conditions
((&optional
) &body body
)
4983 "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
4984 `(call-with-muffled-loader-conditions #'(lambda () ,@body
))))
4987 ;;;; Handle warnings and failures
4988 (with-upgradability ()
4989 (define-condition compile-condition
(condition)
4991 :initform nil
:reader compile-condition-context-format
:initarg
:context-format
)
4993 :initform nil
:reader compile-condition-context-arguments
:initarg
:context-arguments
)
4995 :initform nil
:reader compile-condition-description
:initarg
:description
))
4996 (:report
(lambda (c s
)
4997 (format s
(compatfmt "~@<~A~@[ while ~?~]~@:>")
4998 (or (compile-condition-description c
) (type-of c
))
4999 (compile-condition-context-format c
)
5000 (compile-condition-context-arguments c
)))))
5001 (define-condition compile-file-error
(compile-condition error
) ())
5002 (define-condition compile-warned-warning
(compile-condition warning
) ())
5003 (define-condition compile-warned-error
(compile-condition error
) ())
5004 (define-condition compile-failed-warning
(compile-condition warning
) ())
5005 (define-condition compile-failed-error
(compile-condition error
) ())
5007 (defun check-lisp-compile-warnings (warnings-p failure-p
5008 &optional context-format context-arguments
)
5009 "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
5010 raise an error or warning as appropriate"
5012 (case *compile-file-failure-behaviour
*
5013 (:warn
(warn 'compile-failed-warning
5014 :description
"Lisp compilation failed"
5015 :context-format context-format
5016 :context-arguments context-arguments
))
5017 (:error
(error 'compile-failed-error
5018 :description
"Lisp compilation failed"
5019 :context-format context-format
5020 :context-arguments context-arguments
))
5023 (case *compile-file-warnings-behaviour
*
5024 (:warn
(warn 'compile-warned-warning
5025 :description
"Lisp compilation had style-warnings"
5026 :context-format context-format
5027 :context-arguments context-arguments
))
5028 (:error
(error 'compile-warned-error
5029 :description
"Lisp compilation had style-warnings"
5030 :context-format context-format
5031 :context-arguments context-arguments
))
5034 (defun check-lisp-compile-results (output warnings-p failure-p
5035 &optional context-format context-arguments
)
5036 "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
5038 (error 'compile-file-error
:context-format context-format
:context-arguments context-arguments
))
5039 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments
)))
5042 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
5044 ;;; To support an implementation, three functions must be implemented:
5045 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
5046 ;;; See their respective docstrings.
5047 (with-upgradability ()
5048 (defun reify-simple-sexp (sexp)
5049 "Given a simple SEXP, return a representation of it as a portable SEXP.
5050 Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
5052 (symbol (reify-symbol sexp
))
5053 ((or number character simple-string pathname
) sexp
)
5054 (cons (cons (reify-simple-sexp (car sexp
)) (reify-simple-sexp (cdr sexp
))))
5055 (simple-vector (vector (mapcar 'reify-simple-sexp
(coerce sexp
'list
))))))
5057 (defun unreify-simple-sexp (sexp)
5058 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
5060 ((or symbol number character simple-string pathname
) sexp
)
5061 (cons (cons (unreify-simple-sexp (car sexp
)) (unreify-simple-sexp (cdr sexp
))))
5062 ((simple-vector 2) (unreify-symbol sexp
))
5063 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp
(aref sexp
0)) 'vector
))))
5067 (defun reify-source-note (source-note)
5069 (with-accessors ((source ccl
::source-note-source
) (filename ccl
:source-note-filename
)
5070 (start-pos ccl
:source-note-start-pos
) (end-pos ccl
:source-note-end-pos
)) source-note
5071 (declare (ignorable source
))
5072 (list :filename filename
:start-pos start-pos
:end-pos end-pos
5073 #|
:source
(reify-source-note source
)|
#))))
5074 (defun unreify-source-note (source-note)
5076 (destructuring-bind (&key filename start-pos end-pos source
) source-note
5077 (ccl::make-source-note
:filename filename
:start-pos start-pos
:end-pos end-pos
5078 :source
(unreify-source-note source
)))))
5079 (defun unsymbolify-function-name (name)
5080 (if-let (setfed (gethash name ccl
::%setf-function-name-inverses%
))
5083 (defun symbolify-function-name (name)
5084 (if (and (consp name
) (eq (first name
) 'setf
))
5085 (let ((setfed (second name
)))
5086 (gethash setfed ccl
::%setf-function-names%
))
5088 (defun reify-function-name (function-name)
5089 (let ((name (or (first function-name
) ;; defun: extract the name
5090 (let ((sec (second function-name
)))
5091 (or (and (atom sec
) sec
) ; scoped method: drop scope
5092 (first sec
)))))) ; method: keep gf name, drop method specializers
5094 (defun unreify-function-name (function-name)
5096 (defun nullify-non-literals (sexp)
5098 ((or number character simple-string symbol pathname
) sexp
)
5099 (cons (cons (nullify-non-literals (car sexp
))
5100 (nullify-non-literals (cdr sexp
))))
5102 (defun reify-deferred-warning (deferred-warning)
5103 (with-accessors ((warning-type ccl
::compiler-warning-warning-type
)
5104 (args ccl
::compiler-warning-args
)
5105 (source-note ccl
:compiler-warning-source-note
)
5106 (function-name ccl
:compiler-warning-function-name
)) deferred-warning
5107 (list :warning-type warning-type
:function-name
(reify-function-name function-name
)
5108 :source-note
(reify-source-note source-note
)
5109 :args
(destructuring-bind (fun &rest more
)
5111 (cons (unsymbolify-function-name fun
)
5112 (nullify-non-literals more
))))))
5113 (defun unreify-deferred-warning (reified-deferred-warning)
5114 (destructuring-bind (&key warning-type function-name source-note args
)
5115 reified-deferred-warning
5116 (make-condition (or (cdr (ccl::assq warning-type ccl
::*compiler-whining-conditions
*))
5117 'ccl
::compiler-warning
)
5118 :function-name
(unreify-function-name function-name
)
5119 :source-note
(unreify-source-note source-note
)
5120 :warning-type warning-type
5121 :args
(destructuring-bind (fun . more
) args
5122 (cons (symbolify-function-name fun
) more
))))))
5124 (defun reify-undefined-warning (warning)
5125 ;; Extracting undefined-warnings from the compilation-unit
5126 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5128 (c::undefined-warning-kind warning
)
5129 (c::undefined-warning-name warning
)
5130 (c::undefined-warning-count warning
)
5133 ;; the lexenv slot can be ignored for reporting purposes
5134 `(:enclosing-source
,(c::compiler-error-context-enclosing-source frob
)
5135 :source
,(c::compiler-error-context-source frob
)
5136 :original-source
,(c::compiler-error-context-original-source frob
)
5137 :context
,(c::compiler-error-context-context frob
)
5138 :file-name
,(c::compiler-error-context-file-name frob
) ; a pathname
5139 :file-position
,(c::compiler-error-context-file-position frob
) ; an integer
5140 :original-source-path
,(c::compiler-error-context-original-source-path frob
)))
5141 (c::undefined-warning-warnings warning
))))
5144 (defun reify-undefined-warning (warning)
5145 ;; Extracting undefined-warnings from the compilation-unit
5146 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5148 (sb-c::undefined-warning-kind warning
)
5149 (sb-c::undefined-warning-name warning
)
5150 (sb-c::undefined-warning-count warning
)
5153 ;; the lexenv slot can be ignored for reporting purposes
5154 `(:enclosing-source
,(sb-c::compiler-error-context-enclosing-source frob
)
5155 :source
,(sb-c::compiler-error-context-source frob
)
5156 :original-source
,(sb-c::compiler-error-context-original-source frob
)
5157 :context
,(sb-c::compiler-error-context-context frob
)
5158 :file-name
,(sb-c::compiler-error-context-file-name frob
) ; a pathname
5159 :file-position
,(sb-c::compiler-error-context-file-position frob
) ; an integer
5160 :original-source-path
,(sb-c::compiler-error-context-original-source-path frob
)))
5161 (sb-c::undefined-warning-warnings warning
))))
5163 (defun reify-deferred-warnings ()
5164 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
5165 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
5166 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
5168 (list :functions-defined excl
::.functions-defined.
5169 :functions-called excl
::.functions-called.
)
5171 (mapcar 'reify-deferred-warning
5172 (if-let (dw ccl
::*outstanding-deferred-warnings
*)
5173 (let ((mdw (ccl::ensure-merged-deferred-warnings dw
)))
5174 (ccl::deferred-warnings.warnings mdw
))))
5176 (when lisp
::*in-compilation-unit
*
5177 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5178 `(,@(when c
::*undefined-warnings
*
5179 `((c::*undefined-warnings
*
5180 ,@(mapcar #'reify-undefined-warning c
::*undefined-warnings
*))))
5181 ,@(loop :for what
:in
'(c::*compiler-error-count
*
5182 c
::*compiler-warning-count
*
5183 c
::*compiler-note-count
*)
5184 :for value
= (symbol-value what
)
5186 :collect
`(,what .
,value
))))
5188 (when sb-c
::*in-compilation-unit
*
5189 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5190 `(,@(when sb-c
::*undefined-warnings
*
5191 `((sb-c::*undefined-warnings
*
5192 ,@(mapcar #'reify-undefined-warning sb-c
::*undefined-warnings
*))))
5193 ,@(loop :for what
:in
'(sb-c::*aborted-compilation-unit-count
*
5194 sb-c
::*compiler-error-count
*
5195 sb-c
::*compiler-warning-count
*
5196 sb-c
::*compiler-style-warning-count
*
5197 sb-c
::*compiler-note-count
*)
5198 :for value
= (symbol-value what
)
5200 :collect
`(,what .
,value
)))))
5202 (defun unreify-deferred-warnings (reified-deferred-warnings)
5203 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
5204 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
5205 Handle any warning that has been resolved already,
5206 such as an undefined function that has been defined since.
5207 One of three functions required for deferred-warnings support in ASDF."
5208 (declare (ignorable reified-deferred-warnings
))
5210 (destructuring-bind (&key functions-defined functions-called
)
5211 reified-deferred-warnings
5212 (setf excl
::.functions-defined.
5213 (append functions-defined excl
::.functions-defined.
)
5214 excl
::.functions-called.
5215 (append functions-called excl
::.functions-called.
)))
5217 (let ((dw (or ccl
::*outstanding-deferred-warnings
*
5218 (setf ccl
::*outstanding-deferred-warnings
* (ccl::%defer-warnings t
)))))
5219 (appendf (ccl::deferred-warnings.warnings dw
)
5220 (mapcar 'unreify-deferred-warning reified-deferred-warnings
)))
5222 (dolist (item reified-deferred-warnings
)
5223 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5224 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5225 ;; For everything else, it's an integer.
5226 (destructuring-bind (symbol . adjustment
) item
5228 ((c::*undefined-warnings
*)
5229 (setf c
::*undefined-warnings
*
5232 (destructuring-bind (kind name count . rest
) stuff
5233 (unless (case kind
(:function
(fboundp name
)))
5235 (c::make-undefined-warning
5240 (mapcar #'(lambda (x)
5241 (apply #'c
::make-compiler-error-context x
))
5244 c
::*undefined-warnings
*)))
5246 (set symbol
(+ (symbol-value symbol
) adjustment
))))))
5248 (dolist (item reified-deferred-warnings
)
5249 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5250 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5251 ;; For everything else, it's an integer.
5252 (destructuring-bind (symbol . adjustment
) item
5254 ((sb-c::*undefined-warnings
*)
5255 (setf sb-c
::*undefined-warnings
*
5258 (destructuring-bind (kind name count . rest
) stuff
5259 (unless (case kind
(:function
(fboundp name
)))
5261 (sb-c::make-undefined-warning
5266 (mapcar #'(lambda (x)
5267 (apply #'sb-c
::make-compiler-error-context x
))
5270 sb-c
::*undefined-warnings
*)))
5272 (set symbol
(+ (symbol-value symbol
) adjustment
)))))))
5274 (defun reset-deferred-warnings ()
5275 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
5276 One of three functions required for deferred-warnings support in ASDF."
5278 (setf excl
::.functions-defined. nil
5279 excl
::.functions-called. nil
)
5281 (if-let (dw ccl
::*outstanding-deferred-warnings
*)
5282 (let ((mdw (ccl::ensure-merged-deferred-warnings dw
)))
5283 (setf (ccl::deferred-warnings.warnings mdw
) nil
)))
5285 (when lisp
::*in-compilation-unit
*
5286 (setf c
::*undefined-warnings
* nil
5287 c
::*compiler-error-count
* 0
5288 c
::*compiler-warning-count
* 0
5289 c
::*compiler-note-count
* 0))
5291 (when sb-c
::*in-compilation-unit
*
5292 (setf sb-c
::*undefined-warnings
* nil
5293 sb-c
::*aborted-compilation-unit-count
* 0
5294 sb-c
::*compiler-error-count
* 0
5295 sb-c
::*compiler-warning-count
* 0
5296 sb-c
::*compiler-style-warning-count
* 0
5297 sb-c
::*compiler-note-count
* 0)))
5299 (defun save-deferred-warnings (warnings-file)
5300 "Save forward reference conditions so they may be issued at a latter time,
5301 possibly in a different process."
5302 (with-open-file (s warnings-file
:direction
:output
:if-exists
:supersede
5303 :element-type
*default-stream-element-type
*
5304 :external-format
*utf-8-external-format
*)
5305 (with-safe-io-syntax ()
5306 (let ((*read-eval
* t
))
5307 (write (reify-deferred-warnings) :stream s
:pretty t
:readably t
))
5310 (defun warnings-file-type (&optional implementation-type
)
5311 "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
5312 where NIL designates the current one"
5313 (case (or implementation-type
*implementation-type
*)
5314 ((:acl
:allegro
) "allegro-warnings")
5315 ;;((:clisp) "clisp-warnings")
5316 ((:cmu
:cmucl
) "cmucl-warnings")
5317 ((:sbcl
) "sbcl-warnings")
5318 ((:clozure
:ccl
) "ccl-warnings")
5319 ((:scl
) "scl-warnings")))
5321 (defvar *warnings-file-type
* nil
5322 "Pathname type for warnings files, or NIL if disabled")
5324 (defun enable-deferred-warnings-check ()
5325 "Enable the saving of deferred warnings"
5326 (setf *warnings-file-type
* (warnings-file-type)))
5328 (defun disable-deferred-warnings-check ()
5329 "Disable the saving of deferred warnings"
5330 (setf *warnings-file-type
* nil
))
5332 (defun warnings-file-p (file &optional implementation-type
)
5333 "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
5334 If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
5335 (if-let (type (if implementation-type
5336 (warnings-file-type implementation-type
)
5337 *warnings-file-type
*))
5338 (equal (pathname-type file
) type
)))
5340 (defun check-deferred-warnings (files &optional context-format context-arguments
)
5341 "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
5342 re-intern and raise any warnings that are still meaningful."
5343 (let ((file-errors nil
)
5347 ((warning #'(lambda (c)
5349 (unless (typep c
'style-warning
)
5350 (setf failure-p t
)))))
5351 (with-compilation-unit (:override t
)
5352 (reset-deferred-warnings)
5353 (dolist (file files
)
5354 (unreify-deferred-warnings
5356 (with-safe-io-syntax ()
5357 (let ((*read-eval
* t
))
5358 (read-file-form file
)))
5360 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
5361 (push c file-errors
)
5363 (dolist (error file-errors
) (error error
))
5364 (check-lisp-compile-warnings
5365 (or failure-p warnings-p
) failure-p context-format context-arguments
)))
5368 Mini-guide to adding support for deferred warnings on an implementation.
5370 First
, look at what such a warning looks like
:
5374 (and (eval '(lambda () (some-undefined-function))) nil
)
5377 Then you can grep for the condition type in your compiler sources
5378 and see how to catch those that have been deferred
,
5379 and
/or read
, clear and restore the deferred list.
5382 (macroexpand-1 '(with-compilation-unit () foo
))
5385 (defun call-with-saved-deferred-warnings (thunk warnings-file
&key source-namestring
)
5386 "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
5387 and save those warnings to the given file for latter use,
5388 possibly in a different process. Otherwise just call THUNK."
5389 (declare (ignorable source-namestring
))
5391 (with-compilation-unit (:override t
#+sbcl
:source-namestring
#+sbcl source-namestring
)
5393 (let (#+sbcl
(sb-c::*undefined-warnings
* nil
))
5394 (multiple-value-prog1
5396 (save-deferred-warnings warnings-file
)))
5397 (reset-deferred-warnings)))
5400 (defmacro with-saved-deferred-warnings
((warnings-file &key source-namestring
) &body body
)
5401 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
5402 `(call-with-saved-deferred-warnings
5403 #'(lambda () ,@body
) ,warnings-file
:source-namestring
,source-namestring
)))
5407 (with-upgradability ()
5408 (defun current-lisp-file-pathname ()
5409 "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
5410 (or *compile-file-pathname
* *load-pathname
*))
5412 (defun load-pathname ()
5413 "Portably return the LOAD-PATHNAME of the current source file or fasl"
5414 *load-pathname
*) ;; magic no longer needed for GCL.
5416 (defun lispize-pathname (input-file)
5417 "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
5418 (make-pathname :type
"lisp" :defaults input-file
))
5420 (defun compile-file-type (&rest keys
)
5421 "pathname TYPE for lisp FASt Loading files"
5422 (declare (ignorable keys
))
5423 #-
(or clasp ecl mkcl
) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
5424 #+(or clasp ecl mkcl
) (pathname-type (apply 'compile-file-pathname
"foo" keys
)))
5426 (defun call-around-hook (hook function
)
5427 "Call a HOOK around the execution of FUNCTION"
5428 (call-function (or hook
'funcall
) function
))
5430 (defun compile-file-pathname* (input-file &rest keys
&key output-file
&allow-other-keys
)
5431 "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
5433 (remove-plist-keys `(#+(or (and allegro
(not (version>= 8 2)))) :external-format
5434 ,@(unless output-file
'(:output-file
))) keys
)))
5435 (if (absolute-pathname-p output-file
)
5436 ;; what cfp should be doing, w/ mp* instead of mp
5437 (let* ((type (pathname-type (apply 'compile-file-type keys
)))
5438 (defaults (make-pathname
5439 :type type
:defaults
(merge-pathnames* input-file
))))
5440 (merge-pathnames* output-file defaults
))
5441 (funcall *output-translation-function
*
5442 (apply 'compile-file-pathname input-file keys
)))))
5444 (defvar *compile-check
* nil
5445 "A hook for user-defined compile-time invariants")
5447 (defun* (compile-file*) (input-file &rest keys
5448 &key
(compile-check *compile-check
*) output-file warnings-file
5449 #+clisp lib-file
#+(or clasp ecl mkcl
) object-file
#+sbcl emit-cfasl
5451 "This function provides a portable wrapper around COMPILE-FILE.
5452 It ensures that the OUTPUT-FILE value is only returned and
5453 the file only actually created if the compilation was successful,
5454 even though your implementation may not do that. It also checks an optional
5455 user-provided consistency function COMPILE-CHECK to determine success;
5456 it will call this function if not NIL at the end of the compilation
5457 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
5458 where TMP-FILE is the name of a temporary output-file.
5459 It also checks two flags (with legacy british spelling from ASDF1),
5460 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
5461 with appropriate implementation-dependent defaults,
5462 and if a failure (respectively warnings) are reported by COMPILE-FILE,
5463 it will consider that an error unless the respective behaviour flag
5464 is one of :SUCCESS :WARN :IGNORE.
5465 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
5466 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
5467 On implementations that erroneously do not recognize standard keyword arguments,
5468 it will filter them appropriately."
5470 (when (and object-file
(equal (compile-file-type) (pathname object-file
)))
5471 (format t
"Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
5472 'compile-file
* output-file object-file
)
5473 (rotatef output-file object-file
))
5474 (let* ((keywords (remove-plist-keys
5475 `(:output-file
:compile-check
:warnings-file
5476 #+clisp
:lib-file
#+(or clasp ecl mkcl
) :object-file
) keys
))
5479 (apply 'compile-file-pathname
* input-file
:output-file output-file keywords
)))
5480 (physical-output-file (physicalize-pathname output-file
))
5483 (unless (use-ecl-byte-compiler-p)
5485 #+ecl
(compile-file-pathname output-file
:type
:object
)
5486 #+clasp
(compile-file-pathname output-file
:output-type
:object
))))
5490 (compile-file-pathname output-file
:fasl-p nil
)))
5491 (tmp-file (tmpize-pathname physical-output-file
))
5493 (cfasl-file (etypecase emit-cfasl
5495 ((eql t
) (make-pathname :type
"cfasl" :defaults physical-output-file
))
5496 (string (parse-namestring emit-cfasl
))
5497 (pathname emit-cfasl
)))
5499 (tmp-cfasl (when cfasl-file
(make-pathname :type
"cfasl" :defaults tmp-file
)))
5501 (tmp-lib (make-pathname :type
"lib" :defaults tmp-file
)))
5502 (multiple-value-bind (output-truename warnings-p failure-p
)
5503 (with-enough-pathname (input-file :defaults
*base-build-directory
*)
5504 (with-saved-deferred-warnings (warnings-file :source-namestring
(namestring input-file
))
5505 (with-muffled-compiler-conditions ()
5506 (or #-
(or clasp ecl mkcl
)
5507 (apply 'compile-file input-file
:output-file tmp-file
5508 #+sbcl
(if emit-cfasl
(list* :emit-cfasl tmp-cfasl keywords
) keywords
)
5510 #+ecl
(apply 'compile-file input-file
:output-file
5512 (list* object-file
:system-p t keywords
)
5513 (list* tmp-file keywords
)))
5514 #+clasp
(apply 'compile-file input-file
:output-file
5516 (list* object-file
:output-type
:object
#|
:system-p t|
# keywords
)
5517 (list* tmp-file keywords
)))
5518 #+mkcl
(apply 'compile-file input-file
5519 :output-file object-file
:fasl-p nil keywords
)))))
5521 ((and output-truename
5522 (flet ((check-flag (flag behaviour
)
5523 (or (not flag
) (member behaviour
'(:success
:warn
:ignore
)))))
5524 (and (check-flag failure-p
*compile-file-failure-behaviour
*)
5525 (check-flag warnings-p
*compile-file-warnings-behaviour
*)))
5527 #+(or clasp ecl mkcl
)
5528 (when (and #+(or clasp ecl
) object-file
)
5529 (setf output-truename
5530 (compiler::build-fasl tmp-file
5531 #+(or clasp ecl
) :lisp-files
#+mkcl
:lisp-object-files
(list object-file
))))
5532 (or (not compile-check
)
5533 (apply compile-check input-file
5534 :output-file output-truename
5536 (delete-file-if-exists physical-output-file
)
5537 (when output-truename
5538 #+clasp
(when output-truename
(rename-file-overwriting-target tmp-file output-truename
))
5539 ;; see CLISP bug 677
5542 (setf tmp-lib
(make-pathname :type
"lib" :defaults output-truename
))
5543 (unless lib-file
(setf lib-file
(make-pathname :type
"lib" :defaults physical-output-file
)))
5544 (rename-file-overwriting-target tmp-lib lib-file
))
5545 #+sbcl
(when cfasl-file
(rename-file-overwriting-target tmp-cfasl cfasl-file
))
5546 (rename-file-overwriting-target output-truename physical-output-file
)
5547 (setf output-truename
(truename physical-output-file
)))
5548 #+clasp
(delete-file-if-exists tmp-file
)
5549 #+clisp
(progn (delete-file-if-exists tmp-file
) ;; this one works around clisp BUG 677
5550 (delete-file-if-exists tmp-lib
))) ;; this one is "normal" defensive cleanup
5551 (t ;; error or failed check
5552 (delete-file-if-exists output-truename
)
5553 #+clisp
(delete-file-if-exists tmp-lib
)
5554 #+sbcl
(delete-file-if-exists tmp-cfasl
)
5555 (setf output-truename nil
)))
5556 (values output-truename warnings-p failure-p
))))
5558 (defun load* (x &rest keys
&key
&allow-other-keys
)
5559 "Portable wrapper around LOAD that properly handles loading from a stream."
5560 (with-muffled-loader-conditions ()
5562 ((or pathname string
#-
(or allegro clozure genera
) stream
#+clozure file-stream
)
5563 (apply 'load x keys
))
5564 ;; Genera can't load from a string-input-stream
5565 ;; ClozureCL 1.6 can only load from file input stream
5566 ;; Allegro 5, I don't remember but it must have been broken when I tested.
5567 #+(or allegro clozure genera
)
5568 (stream ;; make do this way
5569 (let ((*package
* *package
*)
5570 (*readtable
* *readtable
*)
5571 (*load-pathname
* nil
)
5572 (*load-truename
* nil
))
5575 (defun load-from-string (string)
5576 "Portably read and evaluate forms from a STRING."
5577 (with-input-from-string (s string
) (load* s
))))
5579 ;;; Links FASLs together
5580 (with-upgradability ()
5581 (defun combine-fasls (inputs output
)
5582 "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
5583 #-
(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl
)
5584 (not-implemented-error 'combine-fasls
"~%inputs: ~S~%output: ~S" inputs output
)
5585 #+abcl
(funcall 'sys
::concatenate-fasls inputs output
) ; requires ABCL 1.2.0
5586 #+(or allegro clisp cmucl sbcl scl xcl
) (concatenate-files inputs output
)
5587 #+clozure
(ccl:fasl-concatenate output inputs
:if-exists
:supersede
)
5592 (loop :for i
:in inputs
5594 :for f
= (add-pathname-suffix
5595 output
(format nil
"-FASL~D" n
))
5598 (ignore-errors (lispworks:delete-system
:fasls-to-concatenate
))
5599 (eval `(scm:defsystem
:fasls-to-concatenate
5600 (:default-pathname
,(pathname-directory-pathname output
))
5602 ,(loop :for f
:in
(reverse fasls
)
5603 :collect
`(,(namestring f
) :load-only t
))))
5604 (scm:concatenate-system output
:fasls-to-concatenate
:force t
))
5605 (loop :for f
:in fasls
:do
(ignore-errors (delete-file f
)))
5606 (ignore-errors (lispworks:delete-system
:fasls-to-concatenate
))))))
5607 ;;;; -------------------------------------------------------------------------
5608 ;;;; launch-program - semi-portably spawn asynchronous subprocesses
5610 (uiop/package
:define-package
:uiop
/launch-program
5611 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
5612 :uiop
/pathname
:uiop
/os
:uiop
/filesystem
:uiop
/stream
)
5614 ;;; Escaping the command invocation madness
5615 #:easy-sh-character-p
#:escape-sh-token
#:escape-sh-command
5616 #:escape-windows-token
#:escape-windows-command
5617 #:escape-shell-token
#:escape-shell-command
5618 #:escape-token
#:escape-command
5622 #:close-streams
#:process-alive-p
#:terminate-process
#:wait-process
5623 #:process-info-error-output
#:process-info-input
#:process-info-output
#:process-info-pid
))
5624 (in-package :uiop
/launch-program
)
5626 ;;;; ----- Escaping strings for the shell -----
5627 (with-upgradability ()
5628 (defun requires-escaping-p (token &key good-chars bad-chars
)
5629 "Does this token require escaping, given the specification of
5630 either good chars that don't need escaping or bad chars that do need escaping,
5631 as either a recognizing function or a sequence of characters."
5634 ((and good-chars bad-chars
)
5635 (parameter-error "~S: only one of good-chars and bad-chars can be provided"
5636 'requires-escaping-p
))
5637 ((typep good-chars
'function
)
5638 (complement good-chars
))
5639 ((typep bad-chars
'function
)
5641 ((and good-chars
(typep good-chars
'sequence
))
5642 #'(lambda (c) (not (find c good-chars
))))
5643 ((and bad-chars
(typep bad-chars
'sequence
))
5644 #'(lambda (c) (find c bad-chars
)))
5645 (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p
)))
5648 (defun escape-token (token &key stream quote good-chars bad-chars escaper
)
5649 "Call the ESCAPER function on TOKEN string if it needs escaping as per
5650 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
5651 using STREAM as output (or returning result as a string if NIL)"
5652 (if (requires-escaping-p token
:good-chars good-chars
:bad-chars bad-chars
)
5653 (with-output (stream)
5654 (apply escaper token stream
(when quote
`(:quote
,quote
))))
5655 (output-string token stream
)))
5657 (defun escape-windows-token-within-double-quotes (x &optional s
)
5658 "Escape a string token X within double-quotes
5659 for use within a MS Windows command-line, outputing to S."
5660 (labels ((issue (c) (princ c s
))
5661 (issue-backslash (n) (loop :repeat n
:do
(issue #\\))))
5663 :initially
(issue #\") :finally
(issue #\")
5664 :with l
= (length x
) :with i
= 0
5665 :for i
+1 = (1+ i
) :while
(< i l
) :do
5667 ((#\") (issue-backslash 1) (issue #\") (setf i i
+1))
5669 (let* ((j (and (< i
+1 l
) (position-if-not
5670 #'(lambda (c) (eql c
#\\)) x
:start i
+1)))
5674 (issue-backslash (* 2 n
)) (setf i l
))
5675 ((and (< j l
) (eql (char x j
) #\"))
5676 (issue-backslash (1+ (* 2 n
))) (issue #\") (setf i
(1+ j
)))
5678 (issue-backslash n
) (setf i j
)))))
5680 (issue (char x i
)) (setf i i
+1))))))
5682 (defun easy-windows-character-p (x)
5683 "Is X an \"easy\" character that does not require quoting by the shell?"
5684 (or (alphanumericp x
) (find x
"+-_.,@:/=")))
5686 (defun escape-windows-token (token &optional s
)
5687 "Escape a string TOKEN within double-quotes if needed
5688 for use within a MS Windows command-line, outputing to S."
5689 (escape-token token
:stream s
:good-chars
#'easy-windows-character-p
:quote nil
5690 :escaper
'escape-windows-token-within-double-quotes
))
5692 (defun escape-sh-token-within-double-quotes (x s
&key
(quote t
))
5693 "Escape a string TOKEN within double-quotes
5694 for use within a POSIX Bourne shell, outputing to S;
5695 omit the outer double-quotes if key argument :QUOTE is NIL"
5696 (when quote
(princ #\" s
))
5697 (loop :for c
:across x
:do
5698 (when (find c
"$`\\\"") (princ #\\ s
))
5700 (when quote
(princ #\" s
)))
5702 (defun easy-sh-character-p (x)
5703 "Is X an \"easy\" character that does not require quoting by the shell?"
5704 (or (alphanumericp x
) (find x
"+-_.,%@:/=")))
5706 (defun escape-sh-token (token &optional s
)
5707 "Escape a string TOKEN within double-quotes if needed
5708 for use within a POSIX Bourne shell, outputing to S."
5709 (escape-token token
:stream s
:quote
#\" :good-chars
#'easy-sh-character-p
5710 :escaper
'escape-sh-token-within-double-quotes
))
5712 (defun escape-shell-token (token &optional s
)
5713 "Escape a token for the current operating system shell"
5715 ((os-unix-p) (escape-sh-token token s
))
5716 ((os-windows-p) (escape-windows-token token s
))))
5718 (defun escape-command (command &optional s
5719 (escaper 'escape-shell-token
))
5720 "Given a COMMAND as a list of tokens, return a string of the
5721 spaced, escaped tokens, using ESCAPER to escape."
5723 (string (output-string command s
))
5724 (list (with-output (s)
5725 (loop :for first
= t
:then nil
:for token
:in command
:do
5726 (unless first
(princ #\space s
))
5727 (funcall escaper token s
))))))
5729 (defun escape-windows-command (command &optional s
)
5730 "Escape a list of command-line arguments into a string suitable for parsing
5731 by CommandLineToArgv in MS Windows"
5732 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
5733 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
5734 (escape-command command s
'escape-windows-token
))
5736 (defun escape-sh-command (command &optional s
)
5737 "Escape a list of command-line arguments into a string suitable for parsing
5738 by /bin/sh in POSIX"
5739 (escape-command command s
'escape-sh-token
))
5741 (defun escape-shell-command (command &optional stream
)
5742 "Escape a command for the current operating system's shell"
5743 (escape-command command stream
'escape-shell-token
)))
5746 (with-upgradability ()
5747 ;;; Internal helpers for run-program
5748 (defun %normalize-io-specifier
(specifier &optional role
)
5749 "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
5750 argument to pass to the internal RUN-PROGRAM"
5751 (declare (ignorable role
))
5753 (null (or #+(or allegro lispworks
) (null-device-pathname)))
5754 (string (parse-native-namestring specifier
))
5755 (pathname specifier
)
5757 ((eql :stream
) :stream
)
5759 #+(or allegro lispworks
) nil
5761 #+(or abcl clozure cmucl ecl mkcl sbcl scl
) t
5762 #-
(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp
)
5763 (not-implemented-error :interactive-output
5764 "On this lisp implementation, cannot interpret ~a value of ~a"
5767 (cond ((eq role
:error-output
)
5768 #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5770 #-
(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5771 (not-implemented-error :error-output-redirect
5772 "Can't send ~a to ~a on this lisp implementation."
5774 (t (parameter-error "~S IO specifier invalid for ~S" specifier role
))))
5776 (parameter-error "Incorrect I/O specifier ~S for ~S"
5779 (defun %interactivep
(input output error-output
)
5780 (member :interactive
(list input output error-output
)))
5782 (defun %signal-to-exit-code
(signum)
5785 (defun %code-to-status
(exit-code signal-code
)
5786 (cond ((null exit-code
) :running
)
5787 ((null signal-code
) (values :exited exit-code
))
5788 (t (values :signaled signal-code
))))
5791 (defun %mkcl-signal-to-number
(signal)
5793 (symbol-value (find-symbol signal
:mk-unix
)))
5795 (defclass process-info
()
5796 (;; The process field is highly platform-, implementation-, and
5797 ;; even version-dependent.
5798 ;; Prior to LispWorks 7, the only information that
5799 ;; `sys:run-shell-command` with `:wait nil` was certain to return
5800 ;; is a PID (e.g. when all streams are nil), hence we stored it
5801 ;; and used `sys:pid-exit-status` to obtain an exit status
5802 ;; later. That is still what we do.
5803 ;; From LispWorks 7 on, if `sys:run-shell-command` does not
5804 ;; return a proper stream, we are instead given a dummy stream.
5805 ;; We can thus always store a stream and use
5806 ;; `sys:pipe-exit-status` to obtain an exit status later.
5807 ;; The advantage of dealing with streams instead of PID is the
5808 ;; availability of functions like `sys:pipe-kill-process`.
5809 (process :initform nil
)
5810 (input-stream :initform nil
)
5811 (output-stream :initform nil
)
5812 (bidir-stream :initform nil
)
5813 (error-output-stream :initform nil
)
5814 ;; For backward-compatibility, to maintain the property (zerop
5815 ;; exit-code) <-> success, an exit in response to a signal is
5816 ;; encoded as 128+signum.
5817 (exit-code :initform nil
)
5818 ;; If the platform allows it, distinguish exiting with a code
5819 ;; >128 from exiting in response to a signal by setting this code
5820 (signal-code :initform nil
)))
5822 ;;;---------------------------------------------------------------------------
5823 ;;; The following two helper functions take care of handling the IF-EXISTS and
5824 ;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
5825 ;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
5826 ;;; function to treat input and output files unconditionally for reading and
5828 ;;;---------------------------------------------------------------------------
5830 (defun %handle-if-exists
(file if-exists
)
5831 (when (or (stringp file
) (pathnamep file
))
5833 ((:append
:supersede
:error
)
5834 (with-open-file (dummy file
:direction
:output
:if-exists if-exists
)
5835 (declare (ignorable dummy
)))))))
5837 (defun %handle-if-does-not-exist
(file if-does-not-exist
)
5838 (when (or (stringp file
) (pathnamep file
))
5839 (ecase if-does-not-exist
5841 (with-open-file (dummy file
:direction
:probe
5842 :if-does-not-exist if-does-not-exist
)
5843 (declare (ignorable dummy
)))))))
5845 (defun process-info-error-output (process-info)
5846 (slot-value process-info
'error-output-stream
))
5847 (defun process-info-input (process-info)
5848 (or (slot-value process-info
'bidir-stream
)
5849 (slot-value process-info
'input-stream
)))
5850 (defun process-info-output (process-info)
5851 (or (slot-value process-info
'bidir-stream
)
5852 (slot-value process-info
'output-stream
)))
5854 (defun process-info-pid (process-info)
5855 (let ((process (slot-value process-info
'process
)))
5856 (declare (ignorable process
))
5857 #+abcl
(symbol-call :sys
:process-pid process
)
5859 #+clozure
(ccl:external-process-id process
)
5860 #+ecl
(ext:external-process-pid process
)
5861 #+(or cmucl scl
) (ext:process-pid process
)
5862 #+lispworks7
+ (sys:pipe-pid process
)
5863 #+(and lispworks
(not lispworks7
+)) process
5864 #+mkcl
(mkcl:process-id process
)
5865 #+sbcl
(sb-ext:process-pid process
)
5866 #-
(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl
)
5867 (not-implemented-error 'process-info-pid
)))
5869 (defun %process-status
(process-info)
5870 (if-let (exit-code (slot-value process-info
'exit-code
))
5871 (return-from %process-status
5872 (if-let (signal-code (slot-value process-info
'signal-code
))
5873 (values :signaled signal-code
)
5874 (values :exited exit-code
))))
5875 #-
(or allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5876 (not-implemented-error '%process-status
)
5877 (if-let (process (slot-value process-info
'process
))
5878 (multiple-value-bind (status code
)
5880 #+allegro
(multiple-value-bind (exit-code pid signal-code
)
5881 (sys:reap-os-subprocess
:pid process
:wait nil
)
5883 (%code-to-status exit-code signal-code
))
5884 #+clozure
(ccl:external-process-status process
)
5885 #+(or cmucl scl
) (let ((status (ext:process-status process
)))
5886 (if (member status
'(:exited
:signaled
))
5887 ;; Calling ext:process-exit-code on
5888 ;; processes that are still alive
5889 ;; yields an undefined result
5890 (values status
(ext:process-exit-code process
))
5892 #+ecl
(ext:external-process-status process
)
5894 ;; a signal is only returned on LispWorks 7+
5895 (multiple-value-bind (exit-code signal-code
)
5897 #+lispworks7
+ :pipe-exit-status
5898 #-lispworks7
+ :pid-exit-status
5900 (%code-to-status exit-code signal-code
))
5901 #+mkcl
(let ((status (mk-ext:process-status process
)))
5902 (if (eq status
:exited
)
5903 ;; Only call mk-ext:process-exit-code when
5904 ;; necessary since it leads to another waitpid()
5905 (let ((code (mk-ext:process-exit-code process
)))
5907 (values :signaled
(%mkcl-signal-to-number code
))
5908 (values :exited code
)))
5910 #+sbcl
(let ((status (sb-ext:process-status process
)))
5911 (if (eq status
:running
)
5913 ;; sb-ext:process-exit-code can also be
5914 ;; called for stopped processes to determine
5915 ;; the signal that stopped them
5916 (values status
(sb-ext:process-exit-code process
)))))
5918 (:exited
(setf (slot-value process-info
'exit-code
) code
))
5919 (:signaled
(let ((%code
(%signal-to-exit-code code
)))
5920 (setf (slot-value process-info
'exit-code
) %code
5921 (slot-value process-info
'signal-code
) code
))))
5923 (values status code
)
5926 (defun process-alive-p (process-info)
5927 "Check if a process has yet to exit."
5928 (unless (slot-value process-info
'exit-code
)
5929 #+abcl
(sys:process-alive-p
(slot-value process-info
'process
))
5930 #+(or cmucl scl
) (ext:process-alive-p
(slot-value process-info
'process
))
5931 #+sbcl
(sb-ext:process-alive-p
(slot-value process-info
'process
))
5932 #-
(or abcl cmucl sbcl scl
) (find (%process-status process-info
)
5933 '(:running
:stopped
:continued
:resumed
))))
5935 (defun wait-process (process-info)
5936 "Wait for the process to terminate, if it is still running.
5937 Otherwise, return immediately. An exit code (a number) will be
5938 returned, with 0 indicating success, and anything else indicating
5939 failure. If the process exits after receiving a signal, the exit code
5940 will be the sum of 128 and the (positive) numeric signal code. A second
5941 value may be returned in this case: the numeric signal code itself.
5942 Any asynchronously spawned process requires this function to be run
5943 before it is garbage-collected in order to free up resources that
5944 might otherwise be irrevocably lost."
5945 (if-let (exit-code (slot-value process-info
'exit-code
))
5946 (if-let (signal-code (slot-value process-info
'signal-code
))
5947 (values exit-code signal-code
)
5949 (let ((process (slot-value process-info
'process
)))
5950 #-
(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5951 (not-implemented-error 'wait-process
)
5954 #+clozure
(ccl::external-process-wait process
)
5955 #+(or cmucl scl
) (ext:process-wait process
)
5956 #+sbcl
(sb-ext:process-wait process
)
5957 ;; 2- extract result
5958 (multiple-value-bind (exit-code signal-code
)
5960 #+abcl
(sys:process-wait process
)
5961 #+allegro
(multiple-value-bind (exit-code pid signal
)
5962 (sys:reap-os-subprocess
:pid process
:wait t
)
5964 (values exit-code signal
))
5965 #+clozure
(multiple-value-bind (status code
)
5966 (ccl:external-process-status process
)
5967 (if (eq status
:signaled
)
5970 #+(or cmucl scl
) (let ((status (ext:process-status process
))
5971 (code (ext:process-exit-code process
)))
5972 (if (eq status
:signaled
)
5975 #+ecl
(multiple-value-bind (status code
)
5976 (ext:external-process-wait process t
)
5977 (if (eq status
:signaled
)
5980 #+lispworks
(symbol-call :sys
5981 #+lispworks7
+ :pipe-exit-status
5982 #-lispworks7
+ :pid-exit-status
5984 #+mkcl
(let ((code (mkcl:join-process process
)))
5986 (values nil
(%mkcl-signal-to-number code
))
5988 #+sbcl
(let ((status (sb-ext:process-status process
))
5989 (code (sb-ext:process-exit-code process
)))
5990 (if (eq status
:signaled
)
5994 (let ((%exit-code
(%signal-to-exit-code signal-code
)))
5995 (setf (slot-value process-info
'exit-code
) %exit-code
5996 (slot-value process-info
'signal-code
) signal-code
)
5997 (values %exit-code signal-code
))
5998 (progn (setf (slot-value process-info
'exit-code
) exit-code
)
6001 ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
6002 ;; do what you expect it to. Sending SIGSTOP to a process spawned
6003 ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
6004 ;; to run the command (via `sh -c command`) but not the actual
6007 (defun %posix-send-signal
(process-info signal
)
6008 #+allegro
(excl.osi
:kill
(slot-value process-info
'process
) signal
)
6009 #+clozure
(ccl:signal-external-process
(slot-value process-info
'process
)
6010 signal
:error-if-exited nil
)
6011 #+(or cmucl scl
) (ext:process-kill
(slot-value process-info
'process
) signal
)
6012 #+sbcl
(sb-ext:process-kill
(slot-value process-info
'process
) signal
)
6013 #-
(or allegro clozure cmucl sbcl scl
)
6014 (if-let (pid (process-info-pid process-info
))
6015 (symbol-call :uiop
:run-program
6016 (format nil
"kill -~a ~a" signal pid
) :ignore-error-status t
)))
6018 ;;; this function never gets called on Windows, but the compiler cannot tell
6019 ;;; that. [2016/09/25:rpg]
6021 (defun %posix-send-signal
(process-info signal
)
6022 (declare (ignore process-info signal
))
6025 (defun terminate-process (process-info &key urgent
)
6026 "Cause the process to exit. To that end, the process may or may
6027 not be sent a signal, which it will find harder (or even impossible)
6028 to ignore if URGENT is T. On some platforms, it may also be subject to
6030 (declare (ignorable urgent
))
6031 #+abcl
(sys:process-kill
(slot-value process-info
'process
))
6032 ;; On ECL, this will only work on versions later than 2016-09-06,
6033 ;; but we still want to compile on earlier versions, so we use symbol-call
6034 #+ecl
(symbol-call :ext
:terminate-process
(slot-value process-info
'process
) urgent
)
6035 #+lispworks7
+ (sys:pipe-kill-process
(slot-value process-info
'process
))
6036 #+mkcl
(mk-ext:terminate-process
(slot-value process-info
'process
)
6038 #-
(or abcl ecl lispworks7
+ mkcl
)
6040 ((os-unix-p) (%posix-send-signal process-info
(if urgent
9 15)))
6041 ((os-windows-p) (if-let (pid (process-info-pid process-info
))
6042 (symbol-call :uiop
:run-program
6043 (format nil
"taskkill ~:[~;/f ~]/pid ~a" urgent pid
)
6044 :ignore-error-status t
)))
6045 (t (not-implemented-error 'terminate-process
))))
6047 (defun close-streams (process-info)
6048 "Close any stream that the process might own. Needs to be run
6049 whenever streams were requested by passing :stream to :input, :output,
6052 (cons (slot-value process-info
'error-output-stream
)
6053 (if-let (bidir-stream (slot-value process-info
'bidir-stream
))
6055 (list (slot-value process-info
'input-stream
)
6056 (slot-value process-info
'output-stream
)))))
6057 (when stream
(close stream
))))
6059 (defun launch-program (command &rest keys
6061 input
(if-input-does-not-exist :error
)
6062 output
(if-output-exists :supersede
)
6063 error-output
(if-error-output-exists :supersede
)
6064 (element-type #-clozure
*default-stream-element-type
*
6065 #+clozure
'character
)
6066 (external-format *utf-8-external-format
*)
6068 #+allegro separate-streams
6070 "Launch program specified by COMMAND,
6071 either a list of strings specifying a program and list of arguments,
6072 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
6073 Windows) _asynchronously_.
6075 If OUTPUT is a pathname, a string designating a pathname, or NIL (the
6076 default) designating the null device, the file at that path is used as
6078 If it's :INTERACTIVE, output is inherited from the current process;
6079 beware that this may be different from your *STANDARD-OUTPUT*, and
6080 under SLIME will be on your *inferior-lisp* buffer. If it's T, output
6081 goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
6082 stream will be made available that can be accessed via
6083 PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
6084 that the underlying lisp implementation knows how to handle.
6086 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
6087 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
6088 default). The meaning of these values and their effect on the case
6089 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
6090 to OPEN with :DIRECTION :OUTPUT.
6092 ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
6093 :OUTPUT means redirecting the error output to the output stream,
6094 and :STREAM causes a stream to be made available via
6095 PROCESS-INFO-ERROR-OUTPUT.
6097 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
6098 affects ERROR-OUTPUT rather than OUTPUT.
6100 INPUT is similar to OUTPUT, except that T designates the
6101 *STANDARD-INPUT* and a stream requested through the :STREAM keyword
6102 would be available through PROCESS-INFO-INPUT.
6104 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
6105 or a pathname, can take the values :CREATE and :ERROR (the
6106 default). The meaning of these values is analogous to the
6107 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
6109 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
6110 implementation, when applicable, for creation of the output stream.
6112 LAUNCH-PROGRAM returns a PROCESS-INFO object."
6113 #-
(or abcl allegro clozure cmucl ecl
(and lispworks os-unix
) mkcl sbcl scl
)
6114 (progn command keys input output error-output directory element-type external-format
6115 if-input-does-not-exist if-output-exists if-error-output-exists
;; ignore
6116 (not-implemented-error 'launch-program
))
6118 (when (some #'(lambda (stream)
6119 (and (streamp stream
)
6120 (not (file-stream-p stream
))))
6121 (list input output error-output
))
6122 (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
6124 #+(or abcl clisp lispworks
)
6125 (when (some #'streamp
(list input output error-output
))
6126 (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
6129 (unless (eq error-output
:interactive
)
6130 (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
6131 'launch-program
:error-output
:interactive
))
6133 (when (some #'(lambda (stream)
6134 (and (streamp stream
)
6135 (not (file-or-synonym-stream-p stream
))))
6136 (list input output error-output
))
6137 (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
6139 #+(or abcl allegro clozure cmucl ecl
(and lispworks os-unix
) mkcl sbcl scl
)
6141 (progn ;; see comments for these functions
6142 (%handle-if-does-not-exist input if-input-does-not-exist
)
6143 (%handle-if-exists output if-output-exists
)
6144 (%handle-if-exists error-output if-error-output-exists
))
6145 #+ecl
(let ((*standard-input
* *stdin
*)
6146 (*standard-output
* *stdout
*)
6147 (*error-output
* *stderr
*)))
6148 (let ((process-info (make-instance 'process-info
))
6149 (input (%normalize-io-specifier input
:input
))
6150 (output (%normalize-io-specifier output
:output
))
6151 (error-output (%normalize-io-specifier error-output
:error-output
))
6152 #+(and allegro os-windows
) (interactive (%interactivep input output error-output
))
6155 #+os-unix
(string `("/bin/sh" "-c" ,command
))
6156 #+os-unix
(list command
)
6159 ;; NB: On other Windows implementations, this is utterly bogus
6160 ;; except in the most trivial cases where no quoting is needed.
6161 ;; Use at your own risk.
6162 #-
(or allegro clisp clozure ecl
)
6164 #+(or ecl sbcl
) (unless (find-symbol* :escape-arguments
#+ecl
:ext
#+sbcl
:sb-impl nil
))
6165 (parameter-error "~S doesn't support string commands on Windows on this Lisp"
6166 'launch-program command
))
6167 ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
6168 ;; when the command contains spaces or special characters:
6169 ;; IIUC, the system will use space as a separator,
6170 ;; but the C++ argv-decoding libraries won't, and
6171 ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
6172 ;; yet neither allegro nor clisp provide access to that argument.
6173 #+(or allegro clisp
) (strcat "cmd /c " command
)
6174 ;; On ClozureCL for Windows, we assume you are using
6175 ;; r15398 or later in 1.9 or later,
6176 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
6177 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
6178 ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
6179 #+(or clozure ecl sbcl
) (cons "cmd" (strcat "/c " command
)))
6182 #+allegro
(escape-windows-command command
)
6183 #-allegro command
)))))
6184 #+(or abcl
(and allegro os-unix
) clozure cmucl ecl mkcl sbcl
)
6185 (let ((program (car command
))
6186 #-allegro
(arguments (cdr command
))))
6187 #+(and (or ecl sbcl
) os-windows
)
6188 (multiple-value-bind (arguments escape-arguments
)
6189 (if (listp arguments
)
6190 (values arguments t
)
6191 (values (list arguments
) nil
)))
6192 #-
(or allegro mkcl sbcl
) (with-current-directory (directory))
6193 (multiple-value-bind
6194 #+(or abcl clozure cmucl sbcl scl
) (process)
6195 #+allegro
(in-or-io out-or-err err-or-pid pid-or-nil
)
6196 #+ecl
(stream code process
)
6197 #+lispworks
(io-or-pid err-or-nil
#-lispworks7
+ pid-or-nil
)
6198 #+mkcl
(stream process code
)
6200 #+abcl
'sys
:run-program
6201 #+allegro
,@'('excl
:run-shell-command
6202 #+os-unix
(coerce (cons program command
) 'vector
)
6203 #+os-windows command
)
6204 #+clozure
'ccl
:run-program
6205 #+(or cmucl ecl scl
) 'ext
:run-program
6206 #+lispworks
,@'('system
:run-shell-command
`("/usr/bin/env" ,@command
)) ; full path needed
6207 #+mkcl
'mk-ext
:run-program
6208 #+sbcl
'sb-ext
:run-program
6209 #+(or abcl clozure cmucl ecl mkcl sbcl
) ,@'(program arguments
)
6210 #+(and (or ecl sbcl
) os-windows
) ,@'(:escape-arguments escape-arguments
)
6211 :input input
:if-input-does-not-exist
:error
6212 :output output
:if-output-exists
:append
6213 ,(or #+(or allegro lispworks
) :error-output
:error
) error-output
6214 ,(or #+(or allegro lispworks
) :if-error-output-exists
:if-error-exists
) :append
6215 :wait nil
:element-type element-type
:external-format external-format
6217 #+allegro
,@`(:directory directory
6218 #+os-windows
,@'(:show-window
(if interactive nil
:hide
)))
6219 #+lispworks
,@'(:save-exit-status t
)
6220 #+mkcl
,@'(:directory
(native-namestring directory
))
6221 #-sbcl keys
;; on SBCL, don't pass :directory nil but remove it from the keys
6222 #+sbcl
,@'(:search t
(if directory keys
(remove-plist-key :directory keys
)))))
6223 (labels ((prop (key value
) (setf (slot-value process-info key
) value
)))
6227 (prop 'process pid-or-nil
)
6228 (when (eq input
:stream
) (prop 'input-stream in-or-io
))
6229 (when (eq output
:stream
) (prop 'output-stream out-or-err
))
6230 (when (eq error-output
:stream
) (prop 'error-stream err-or-pid
)))
6232 (prop 'process err-or-pid
)
6233 (ecase (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))
6235 (1 (prop 'input-stream in-or-io
))
6236 (2 (prop 'output-stream in-or-io
))
6237 (3 (prop 'bidir-stream in-or-io
)))
6238 (when (eq error-output
:stream
)
6239 (prop 'error-stream out-or-err
))))
6240 #+(or abcl clozure cmucl sbcl scl
)
6242 (prop 'process process
)
6243 (when (eq input
:stream
)
6245 (prop 'input-stream
)
6246 #+abcl
(symbol-call :sys
:process-input
)
6247 #+clozure
(ccl:external-process-input-stream
)
6248 #+(or cmucl scl
) (ext:process-input
)
6249 #+sbcl
(sb-ext:process-input
)
6251 (when (eq output
:stream
)
6253 (prop 'output-stream
)
6254 #+abcl
(symbol-call :sys
:process-output
)
6255 #+clozure
(ccl:external-process-output-stream
)
6256 #+(or cmucl scl
) (ext:process-output
)
6257 #+sbcl
(sb-ext:process-output
)
6259 (when (eq error-output
:stream
)
6261 (prop 'error-output-stream
)
6262 #+abcl
(symbol-call :sys
:process-error
)
6263 #+clozure
(ccl:external-process-error-stream
)
6264 #+(or cmucl scl
) (ext:process-error
)
6265 #+sbcl
(sb-ext:process-error
)
6268 (let ((mode (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))))
6270 (unless (zerop mode
)
6271 (prop (case mode
(1 'input-stream
) (2 'output-stream
) (3 'bidir-stream
)) stream
))
6272 (prop 'process process
))
6274 ;; See also the comments on the process-info class
6275 (let ((mode (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))))
6277 ((or (plusp mode
) (eq error-output
:stream
))
6278 (prop 'process
#+lispworks7
+ io-or-pid
#-lispworks7
+ pid-or-nil
)
6280 (prop (ecase mode
(1 'input-stream
) (2 'output-stream
) (3 'bidir-stream
))
6282 (when (eq error-output
:stream
)
6283 (prop 'error-stream err-or-nil
)))
6284 ;; Prior to Lispworks 7, this returned (pid); now it
6285 ;; returns (io err pid) of which we keep io.
6286 (t (prop 'process io-or-pid
)))))
6289 ;;;; -------------------------------------------------------------------------
6290 ;;;; run-program initially from xcvb-driver.
6292 (uiop/package
:define-package
:uiop
/run-program
6293 (:nicknames
:asdf
/run-program
) ; OBSOLETE. Used by cl-sane, printv.
6294 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/version
6295 :uiop
/pathname
:uiop
/os
:uiop
/filesystem
:uiop
/stream
:uiop
/launch-program
)
6298 #:slurp-input-stream
#:vomit-output-stream
6300 #:subprocess-error-code
#:subprocess-error-command
#:subprocess-error-process
)
6301 (:import-from
:uiop
/launch-program
6302 #:%handle-if-does-not-exist
#:%handle-if-exists
#:%interactivep
6303 #:input-stream
#:output-stream
#:error-output-stream
))
6304 (in-package :uiop
/run-program
)
6306 ;;;; Slurping a stream, typically the output of another program
6307 (with-upgradability ()
6308 (defun call-stream-processor (fun processor stream
)
6309 "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
6310 a PROCESSOR specification which is either an atom or a list specifying
6311 a processor an keyword arguments, call the specified processor with
6312 the given STREAM as input"
6313 (if (consp processor
)
6314 (apply fun
(first processor
) stream
(rest processor
))
6315 (funcall fun processor stream
)))
6317 (defgeneric slurp-input-stream
(processor input-stream
&key
)
6319 "SLURP-INPUT-STREAM is a generic function with two positional arguments
6320 PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
6321 the contents of the INPUT-STREAM and processes them according to a method
6322 specified by PROCESSOR.
6324 Built-in methods include the following:
6325 * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
6326 * if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
6327 INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
6328 \(APPLY x <stream> y\)
6329 * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
6330 per copy-stream-to-stream, with appropriate keyword arguments.
6331 * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
6332 are returned as a string, as per SLURP-STREAM-STRING.
6333 * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
6334 * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
6335 * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
6336 * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
6337 * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
6339 Programmers are encouraged to define their own methods for this generic function."))
6342 (defmethod slurp-input-stream ((function function
) input-stream
&key
)
6343 (funcall function input-stream
))
6345 (defmethod slurp-input-stream ((list cons
) input-stream
&key
)
6346 (apply (first list
) input-stream
(rest list
)))
6349 (defmethod slurp-input-stream ((output-stream stream
) input-stream
6350 &key linewise prefix
(element-type 'character
) buffer-size
)
6351 (copy-stream-to-stream
6352 input-stream output-stream
6353 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6355 (defmethod slurp-input-stream ((x (eql 'string
)) stream
&key stripped
)
6356 (slurp-stream-string stream
:stripped stripped
))
6358 (defmethod slurp-input-stream ((x (eql :string
)) stream
&key stripped
)
6359 (slurp-stream-string stream
:stripped stripped
))
6361 (defmethod slurp-input-stream ((x (eql :lines
)) stream
&key count
)
6362 (slurp-stream-lines stream
:count count
))
6364 (defmethod slurp-input-stream ((x (eql :line
)) stream
&key
(at 0))
6365 (slurp-stream-line stream
:at at
))
6367 (defmethod slurp-input-stream ((x (eql :forms
)) stream
&key count
)
6368 (slurp-stream-forms stream
:count count
))
6370 (defmethod slurp-input-stream ((x (eql :form
)) stream
&key
(at 0))
6371 (slurp-stream-form stream
:at at
))
6373 (defmethod slurp-input-stream ((x (eql t
)) stream
&rest keys
&key
&allow-other-keys
)
6374 (apply 'slurp-input-stream
*standard-output
* stream keys
))
6376 (defmethod slurp-input-stream ((x null
) (stream t
) &key
)
6379 (defmethod slurp-input-stream ((pathname pathname
) input
6381 (element-type *default-stream-element-type
*)
6382 (external-format *utf-8-external-format
*)
6383 (if-exists :rename-and-delete
)
6384 (if-does-not-exist :create
)
6387 (with-output-file (output pathname
6388 :element-type element-type
6389 :external-format external-format
6390 :if-exists if-exists
6391 :if-does-not-exist if-does-not-exist
)
6392 (copy-stream-to-stream
6394 :element-type element-type
:buffer-size buffer-size
:linewise linewise
)))
6396 (defmethod slurp-input-stream (x stream
6397 &key linewise prefix
(element-type 'character
) buffer-size
)
6398 (declare (ignorable stream linewise prefix element-type buffer-size
))
6401 ((functionp x
) (funcall x stream
))
6403 ((output-stream-p x
)
6404 (copy-stream-to-stream
6406 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6408 (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x
)))))
6410 ;;;; Vomiting a stream, typically into the input of another program.
6411 (with-upgradability ()
6412 (defgeneric vomit-output-stream
(processor output-stream
&key
)
6414 "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
6415 PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
6416 some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
6418 Built-in methods include the following:
6419 * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
6420 * if PROCESSOR is a list, its first element should be a function.
6421 It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
6422 That is (x . y) will be treated as \(APPLY x <stream> y\)
6423 * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
6424 per copy-stream-to-stream, with appropriate keyword arguments.
6425 * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
6426 * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
6428 Programmers are encouraged to define their own methods for this generic function."))
6431 (defmethod vomit-output-stream ((function function
) output-stream
&key
)
6432 (funcall function output-stream
))
6434 (defmethod vomit-output-stream ((list cons
) output-stream
&key
)
6435 (apply (first list
) output-stream
(rest list
)))
6438 (defmethod vomit-output-stream ((input-stream stream
) output-stream
6439 &key linewise prefix
(element-type 'character
) buffer-size
)
6440 (copy-stream-to-stream
6441 input-stream output-stream
6442 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6444 (defmethod vomit-output-stream ((x string
) stream
&key fresh-line terpri
)
6446 (when fresh-line
(fresh-line stream
))
6447 (when terpri
(terpri stream
))
6450 (defmethod vomit-output-stream ((x (eql t
)) stream
&rest keys
&key
&allow-other-keys
)
6451 (apply 'vomit-output-stream
*standard-input
* stream keys
))
6453 (defmethod vomit-output-stream ((x null
) (stream t
) &key
)
6456 (defmethod vomit-output-stream ((pathname pathname
) input
6458 (element-type *default-stream-element-type
*)
6459 (external-format *utf-8-external-format
*)
6460 (if-exists :rename-and-delete
)
6461 (if-does-not-exist :create
)
6464 (with-output-file (output pathname
6465 :element-type element-type
6466 :external-format external-format
6467 :if-exists if-exists
6468 :if-does-not-exist if-does-not-exist
)
6469 (copy-stream-to-stream
6471 :element-type element-type
:buffer-size buffer-size
:linewise linewise
)))
6473 (defmethod vomit-output-stream (x stream
6474 &key linewise prefix
(element-type 'character
) buffer-size
)
6475 (declare (ignorable stream linewise prefix element-type buffer-size
))
6478 ((functionp x
) (funcall x stream
))
6481 (copy-stream-to-stream
6483 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6485 (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x
)))))
6488 ;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
6489 (with-upgradability ()
6490 (define-condition subprocess-error
(error)
6491 ((code :initform nil
:initarg
:code
:reader subprocess-error-code
)
6492 (command :initform nil
:initarg
:command
:reader subprocess-error-command
)
6493 (process :initform nil
:initarg
:process
:reader subprocess-error-process
))
6494 (:report
(lambda (condition stream
)
6495 (format stream
"Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
6496 (subprocess-error-process condition
)
6497 (subprocess-error-command condition
)
6498 (subprocess-error-code condition
)))))
6500 (defun %check-result
(exit-code &key command process ignore-error-status
)
6501 (unless ignore-error-status
6502 (unless (eql exit-code
0)
6503 (cerror "IGNORE-ERROR-STATUS"
6504 'subprocess-error
:command command
:code exit-code
:process process
)))
6507 (defun %active-io-specifier-p
(specifier)
6508 "Determines whether a run-program I/O specifier requires Lisp-side processing
6509 via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
6510 or whether it's already taken care of by the implementation's underlying run-program."
6511 (not (typep specifier
'(or null string pathname
(member :interactive
:output
)
6512 #+(or cmucl
(and sbcl os-unix
) scl
) (or stream
(eql t
))
6513 #+lispworks file-stream
))))
6515 (defun %run-program
(command &rest keys
&key
&allow-other-keys
)
6516 "DEPRECATED. Use LAUNCH-PROGRAM instead."
6517 (apply 'launch-program command keys
))
6519 (defun %call-with-program-io
(gf tval stream-easy-p fun direction spec activep returner
6521 (element-type #-clozure
*default-stream-element-type
* #+clozure
'character
)
6522 (external-format *utf-8-external-format
*) &allow-other-keys
)
6523 ;; handle redirection for run-program and system
6524 ;; SPEC is the specification for the subprocess's input or output or error-output
6525 ;; TVAL is the value used if the spec is T
6526 ;; GF is the generic function to call to handle arbitrary values of SPEC
6527 ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
6528 ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
6529 ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
6530 ;; FUN is a function of the new reduced spec and an activity function to call with a stream
6531 ;; when the subprocess is active and communicating through that stream.
6532 ;; ACTIVEP is a boolean true if we will get to run code while the process is running
6533 ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
6534 ;; RETURNER is a function called with the value of the activity.
6535 ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
6536 (declare (ignorable stream-easy-p
))
6537 (let* ((actual-spec (if (eq spec t
) tval spec
))
6538 (activity-spec (if (eq actual-spec
:output
)
6541 (parameter-error "~S does not allow ~S as a ~S spec"
6542 'run-program
:output direction
))
6546 (labels ((activity (stream)
6547 (call-function returner
(call-stream-processor gf activity-spec stream
)))
6549 (funcall fun actual-spec nil
))
6552 (funcall fun
:stream
#'activity
)
6553 (with-temporary-file (:pathname tmp
)
6556 (with-output-file (s tmp
:if-exists
:overwrite
6557 :external-format external-format
6558 :element-type element-type
)
6560 (funcall fun tmp nil
))
6561 ((:output
:error-output
)
6562 (multiple-value-prog1 (funcall fun tmp nil
)
6563 (with-input-file (s tmp
6564 :external-format external-format
6565 :element-type element-type
)
6566 (activity s
)))))))))
6567 (typecase activity-spec
6568 ((or null string pathname
(eql :interactive
))
6570 #+(or cmucl
(and sbcl os-unix
) scl
) ;; streams are only easy on implementations that try very hard
6572 (if stream-easy-p
(easy-case) (hard-case)))
6576 (defmacro place-setter
(place)
6578 (let ((value (gensym)))
6579 `#'(lambda (,value
) (setf ,place
,value
)))))
6581 (defmacro with-program-input
(((reduced-input-var
6582 &optional
(input-activity-var (gensym) iavp
))
6583 input-form
&key setf stream-easy-p active keys
) &body body
)
6584 `(apply '%call-with-program-io
'vomit-output-stream
*standard-input
* ,stream-easy-p
6585 #'(lambda (,reduced-input-var
,input-activity-var
)
6586 ,@(unless iavp
`((declare (ignore ,input-activity-var
))))
6588 :input
,input-form
,active
(place-setter ,setf
) ,keys
))
6590 (defmacro with-program-output
(((reduced-output-var
6591 &optional
(output-activity-var (gensym) oavp
))
6592 output-form
&key setf stream-easy-p active keys
) &body body
)
6593 `(apply '%call-with-program-io
'slurp-input-stream
*standard-output
* ,stream-easy-p
6594 #'(lambda (,reduced-output-var
,output-activity-var
)
6595 ,@(unless oavp
`((declare (ignore ,output-activity-var
))))
6597 :output
,output-form
,active
(place-setter ,setf
) ,keys
))
6599 (defmacro with-program-error-output
(((reduced-error-output-var
6600 &optional
(error-output-activity-var (gensym) eoavp
))
6601 error-output-form
&key setf stream-easy-p active keys
)
6603 `(apply '%call-with-program-io
'slurp-input-stream
*error-output
* ,stream-easy-p
6604 #'(lambda (,reduced-error-output-var
,error-output-activity-var
)
6605 ,@(unless eoavp
`((declare (ignore ,error-output-activity-var
))))
6607 :error-output
,error-output-form
,active
(place-setter ,setf
) ,keys
))
6609 (defun %use-launch-program
(command &rest keys
6610 &key input output error-output ignore-error-status
&allow-other-keys
)
6611 ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
6612 #+(or cormanlisp gcl
(and lispworks os-windows
) mcl xcl
)
6614 command keys input output error-output ignore-error-status
;; ignore
6615 (not-implemented-error '%use-launch-program
))
6616 (when (member :stream
(list input output error-output
))
6617 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
6618 'run-program
:stream
))
6619 (let* ((active-input-p (%active-io-specifier-p input
))
6620 (active-output-p (%active-io-specifier-p output
))
6621 (active-error-output-p (%active-io-specifier-p error-output
))
6624 (active-output-p :output
)
6625 (active-input-p :input
)
6626 (active-error-output-p :error-output
)
6628 output-result error-output-result exit-code process-info
)
6629 (with-program-output ((reduced-output output-activity
)
6630 output
:keys keys
:setf output-result
6631 :stream-easy-p t
:active
(eq activity
:output
))
6632 (with-program-error-output ((reduced-error-output error-output-activity
)
6633 error-output
:keys keys
:setf error-output-result
6634 :stream-easy-p t
:active
(eq activity
:error-output
))
6635 (with-program-input ((reduced-input input-activity
)
6637 :stream-easy-p t
:active
(eq activity
:input
))
6639 (apply 'launch-program command
6640 :input reduced-input
:output reduced-output
6641 :error-output
(if (eq error-output
:output
) :output reduced-error-output
)
6643 (labels ((get-stream (stream-name &optional fallbackp
)
6644 (or (slot-value process-info stream-name
)
6646 (slot-value process-info
'bidir-stream
))))
6647 (run-activity (activity stream-name
&optional fallbackp
)
6648 (if-let (stream (get-stream stream-name fallbackp
))
6649 (funcall activity stream
)
6650 (error 'subprocess-error
6651 :code
`(:missing
,stream-name
)
6652 :command command
:process process-info
))))
6656 (:input
(run-activity input-activity
'input-stream t
))
6657 (:output
(run-activity output-activity
'output-stream t
))
6658 (:error-output
(run-activity error-output-activity
'error-output-stream
)))
6659 (close-streams process-info
)
6660 (setf exit-code
(wait-process process-info
)))))))
6661 (%check-result exit-code
6662 :command command
:process process-info
6663 :ignore-error-status ignore-error-status
)
6664 (values output-result error-output-result exit-code
)))
6666 (defun %normalize-system-command
(command) ;; helper for %USE-SYSTEM
6669 (list (escape-shell-command
6671 ((os-unix-p) (cons "exec" command
))
6674 (defun %redirected-system-command
(command in out err directory
) ;; helper for %USE-SYSTEM
6675 (flet ((redirect (spec operator
)
6678 (null (null-device-pathname))
6679 (string (parse-native-namestring spec
))
6682 (unless (equal operator
" 2>>")
6683 (parameter-error "~S: only the ~S argument can be ~S"
6684 'run-program
:error-output
:output
))
6685 (return-from redirect
'(" 2>&1"))))))
6688 (escape-shell-token (native-namestring pathname
)))))))
6689 (let* ((redirections (append (redirect in
" <") (redirect out
" >>") (redirect err
" 2>>")))
6690 (normalized (%normalize-system-command command
))
6691 (directory (or directory
#+(or abcl xcl
) (getcwd)))
6692 (chdir (when directory
6693 (let ((dir-arg (escape-shell-token (native-namestring directory
))))
6695 ((os-unix-p) `("cd " ,dir-arg
" ; "))
6696 ((os-windows-p) `("cd /d " ,dir-arg
" & ")))))))
6699 ((os-unix-p) `(,@(when redirections
`("exec " ,@redirections
" ; ")) ,@chdir
,normalized
))
6700 ((os-windows-p) `(,@redirections
" (" ,@chdir
,normalized
")")))))))
6702 (defun %system
(command &rest keys
&key directory
6703 input
(if-input-does-not-exist :error
)
6704 output
(if-output-exists :supersede
)
6705 error-output
(if-error-output-exists :supersede
)
6707 "A portable abstraction of a low-level call to libc's system()."
6708 (declare (ignorable keys directory input if-input-does-not-exist output
6709 if-output-exists error-output if-error-output-exists
))
6710 (when (member :stream
(list input output error-output
))
6711 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
6712 'run-program
:stream
))
6713 #+(or abcl allegro clozure cmucl ecl
(and lispworks os-unix
) mkcl sbcl scl
)
6714 (let (#+(or abcl ecl mkcl
)
6715 (version (parse-version
6717 (lisp-implementation-version)
6719 (second (split-string (implementation-identifier) :separator
'(#\-
))))))
6721 #+abcl
(unless (lexicographic< '< version
'(1 4 0)))
6722 #+ecl
(unless (lexicographic<= '< version
'(16 0 0)))
6723 #+mkcl
(unless (lexicographic<= '< version
'(1 1 9)))
6724 (return-from %system
6726 (apply 'launch-program
(%normalize-system-command command
) keys
)))))
6727 #+(or abcl clasp clisp cormanlisp ecl gcl genera
(and lispworks os-windows
) mkcl xcl
)
6728 (let ((%command
(%redirected-system-command command input output error-output directory
)))
6729 ;; see comments for these functions
6730 (%handle-if-does-not-exist input if-input-does-not-exist
)
6731 (%handle-if-exists output if-output-exists
)
6732 (%handle-if-exists error-output if-error-output-exists
)
6733 #+abcl
(ext:run-shell-command %command
)
6734 #+(or clasp ecl
) (let ((*standard-input
* *stdin
*)
6735 (*standard-output
* *stdout
*)
6736 (*error-output
* *stderr
*))
6737 (ext:system %command
))
6739 (let ((raw-exit-code
6741 #.
`(#+os-windows
,@'(ext:run-shell-command %command
)
6742 #+os-unix
,@'(ext:run-program
"/bin/sh" :arguments
`("-c" ,%command
))
6743 :wait t
:input
:terminal
:output
:terminal
)
6745 (if (minusp raw-exit-code
)
6746 (- 128 raw-exit-code
)
6748 #+cormanlisp
(win32:system %command
)
6749 #+gcl
(system:system %command
)
6750 #+genera
(not-implemented-error '%system
)
6751 #+(and lispworks os-windows
)
6752 (system:call-system %command
:current-directory directory
:wait t
)
6753 #+mcl
(ccl::with-cstrs
((%%command %command
)) (_system %%command
))
6754 #+mkcl
(mkcl:system %command
)
6755 #+xcl
(system:%run-shell-command %command
)))
6757 (defun %use-system
(command &rest keys
6758 &key input output error-output ignore-error-status
&allow-other-keys
)
6759 ;; helper for RUN-PROGRAM when using %system
6760 (let (output-result error-output-result exit-code
)
6761 (with-program-output ((reduced-output)
6762 output
:keys keys
:setf output-result
)
6763 (with-program-error-output ((reduced-error-output)
6764 error-output
:keys keys
:setf error-output-result
)
6765 (with-program-input ((reduced-input) input
:keys keys
)
6766 (setf exit-code
(apply '%system command
6767 :input reduced-input
:output reduced-output
6768 :error-output reduced-error-output keys
)))))
6769 (%check-result exit-code
6771 :ignore-error-status ignore-error-status
)
6772 (values output-result error-output-result exit-code
)))
6774 (defun run-program (command &rest keys
6775 &key ignore-error-status
(force-shell nil force-shell-suppliedp
)
6776 input
(if-input-does-not-exist :error
)
6777 output
(if-output-exists :supersede
)
6778 error-output
(if-error-output-exists :supersede
)
6779 (element-type #-clozure
*default-stream-element-type
* #+clozure
'character
)
6780 (external-format *utf-8-external-format
*)
6782 "Run program specified by COMMAND,
6783 either a list of strings specifying a program and list of arguments,
6784 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
6785 _synchronously_ process its output as specified and return the processing results
6786 when the program and its output processing are complete.
6788 Always call a shell (rather than directly execute the command when possible)
6789 if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
6790 specified to be NIL.
6792 Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
6793 unless IGNORE-ERROR-STATUS is specified.
6795 If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
6796 designating the null device, the file at that path is used as output.
6797 If it's :INTERACTIVE, output is inherited from the current process;
6798 beware that this may be different from your *STANDARD-OUTPUT*,
6799 and under SLIME will be on your *inferior-lisp* buffer.
6800 If it's T, output goes to your current *STANDARD-OUTPUT* stream.
6801 Otherwise, OUTPUT should be a value that is a suitable first argument to
6802 SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
6803 In this case, RUN-PROGRAM will create a temporary stream for the program output;
6804 the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
6805 using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
6806 The primary value resulting from that call (or NIL if no call was needed)
6807 will be the first value returned by RUN-PROGRAM.
6808 E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
6809 And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
6810 stripped of any ending newline.
6812 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
6813 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
6814 default). The meaning of these values and their effect on the case
6815 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
6816 to OPEN with :DIRECTION :OUTPUT.
6818 ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
6819 as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
6820 Also :OUTPUT means redirecting the error output to the output stream,
6821 in which case NIL is returned.
6823 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
6824 affects ERROR-OUTPUT rather than OUTPUT.
6826 INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
6827 no value is returned, and T designates the *STANDARD-INPUT*.
6829 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
6830 or a pathname, can take the values :CREATE and :ERROR (the
6831 default). The meaning of these values is analogous to the
6832 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
6834 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
6835 to your Lisp implementation, when applicable, for creation of the output stream.
6837 One and only one of the stream slurping or vomiting may or may not happen
6838 in parallel in parallel with the subprocess,
6839 depending on options and implementation,
6840 and with priority being given to output processing.
6841 Other streams are completely produced or consumed
6842 before or after the subprocess is spawned, using temporary files.
6844 RUN-PROGRAM returns 3 values:
6845 0- the result of the OUTPUT slurping if any, or NIL
6846 1- the result of the ERROR-OUTPUT slurping if any, or NIL
6847 2- either 0 if the subprocess exited with success status,
6848 or an indication of failure via the EXIT-CODE of the process"
6849 (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
6850 if-error-output-exists element-type external-format ignore-error-status
))
6851 #-
(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl
)
6852 (not-implemented-error 'run-program
)
6853 (apply (if (or force-shell
6854 ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
6855 ;; But don't override user's specified preference. [2015/06/29:rpg]
6856 (and (stringp command
)
6857 (or (not force-shell-suppliedp
)
6858 #-
(or allegro clisp clozure sbcl
) (os-cond ((os-windows-p) t
))))
6859 #+(or clasp clisp cormanlisp gcl
(and lispworks os-windows
) mcl xcl
) t
6860 ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
6861 #+ecl
#.
(if-let (ver (parse-version (lisp-implementation-version)))
6862 (lexicographic<= '< ver
'(16 0 0)))
6863 #+(and lispworks os-unix
) (%interactivep input output error-output
))
6864 '%use-system
'%use-launch-program
)
6867 ;;;; ---------------------------------------------------------------------------
6868 ;;;; Generic support for configuration files
6870 (uiop/package
:define-package
:uiop
/configuration
6871 (:recycle
:uiop
/configuration
:asdf
/configuration
) ;; necessary to upgrade from 2.27.
6872 (:use
:uiop
/common-lisp
:uiop
/utility
6873 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
:uiop
/lisp-build
)
6875 #:user-configuration-directories
#:system-configuration-directories
;; implemented in backward-driver
6876 #:in-first-directory
#:in-user-configuration-directory
#:in-system-configuration-directory
;; idem
6878 #:xdg-data-home
#:xdg-config-home
#:xdg-data-dirs
#:xdg-config-dirs
6879 #:xdg-cache-home
#:xdg-runtime-dir
#:system-config-pathnames
6880 #:filter-pathname-set
#:xdg-data-pathnames
#:xdg-config-pathnames
6881 #:find-preferred-file
#:xdg-data-pathname
#:xdg-config-pathname
6882 #:validate-configuration-form
#:validate-configuration-file
#:validate-configuration-directory
6883 #:configuration-inheritance-directive-p
6884 #:report-invalid-form
#:invalid-configuration
#:*ignored-configuration-form
* #:*user-cache
*
6885 #:*clear-configuration-hook
* #:clear-configuration
#:register-clear-configuration-hook
6886 #:resolve-location
#:location-designator-p
#:location-function-p
#:*here-directory
*
6887 #:resolve-relative-location
#:resolve-absolute-location
#:upgrade-configuration
))
6888 (in-package :uiop
/configuration
)
6890 (with-upgradability ()
6891 (define-condition invalid-configuration
()
6892 ((form :reader condition-form
:initarg
:form
)
6893 (location :reader condition-location
:initarg
:location
)
6894 (format :reader condition-format
:initarg
:format
)
6895 (arguments :reader condition-arguments
:initarg
:arguments
:initform nil
))
6896 (:report
(lambda (c s
)
6897 (format s
(compatfmt "~@<~? (will be skipped)~@:>")
6898 (condition-format c
)
6899 (list* (condition-form c
) (condition-location c
)
6900 (condition-arguments c
))))))
6902 (defun configuration-inheritance-directive-p (x)
6903 "Is X a configuration inheritance directive?"
6904 (let ((kw '(:inherit-configuration
:ignore-inherited-configuration
)))
6906 (and (length=n-p x
1) (member (car x
) kw
)))))
6908 (defun report-invalid-form (reporter &rest args
)
6909 "Report an invalid form according to REPORTER and various ARGS"
6912 (apply 'error
'invalid-configuration args
))
6914 (apply reporter args
))
6916 (apply 'error reporter args
))
6918 (apply 'apply
(append reporter args
)))))
6920 (defvar *ignored-configuration-form
* nil
6921 "Have configuration forms been ignored while parsing the configuration?")
6923 (defun validate-configuration-form (form tag directive-validator
6924 &key location invalid-form-reporter
)
6925 "Validate a configuration FORM. By default it will raise an error if the
6926 FORM is not valid. Otherwise it will return the validated form.
6927 Arguments control the behavior:
6928 The configuration FORM should be of the form (TAG . <rest>)
6929 Each element of <rest> will be checked by first seeing if it's a configuration inheritance
6930 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
6932 In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
6933 reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
6934 the configuration form appeared."
6935 (unless (and (consp form
) (eq (car form
) tag
))
6936 (setf *ignored-configuration-form
* t
)
6937 (report-invalid-form invalid-form-reporter
:form form
:location location
)
6938 (return-from validate-configuration-form nil
))
6939 (loop :with inherit
= 0 :with ignore-invalid-p
= nil
:with x
= (list tag
)
6940 :for directive
:in
(cdr form
)
6942 ((configuration-inheritance-directive-p directive
)
6944 ((eq directive
:ignore-invalid-entries
)
6945 (setf ignore-invalid-p t
) t
)
6946 ((funcall directive-validator directive
)
6951 (setf *ignored-configuration-form
* t
)
6952 (report-invalid-form invalid-form-reporter
:form directive
:location location
)
6954 :do
(push directive x
)
6956 (unless (= inherit
1)
6957 (report-invalid-form invalid-form-reporter
6958 :form form
:location location
6959 ;; we throw away the form and location arguments, hence the ~2*
6960 ;; this is necessary because of the report in INVALID-CONFIGURATION
6961 :format
(compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
6962 One and only one of ~S or ~S is required.~@:>")
6963 :arguments
'(:inherit-configuration
:ignore-inherited-configuration
)))
6964 (return (nreverse x
))))
6966 (defun validate-configuration-file (file validator
&key description
)
6967 "Validate a configuration FILE. The configuration file should have only one s-expression
6968 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
6970 (let ((forms (read-file-forms file
)))
6971 (unless (length=n-p forms
1)
6972 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
6974 (funcall validator
(car forms
) :location file
)))
6976 (defun validate-configuration-directory (directory tag validator
&key invalid-form-reporter
)
6977 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
6978 be applied to the results to yield a configuration form. Current
6979 values of TAG include :source-registry and :output-translations."
6980 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
6983 (directory* (make-pathname :name
*wild
* :type
"conf" :defaults directory
))))
6984 #'string
< :key
#'namestring
)))
6986 ,@(loop :for file
:in files
:append
6987 (loop :with ignore-invalid-p
= nil
6988 :for form
:in
(read-file-forms file
)
6989 :when
(eq form
:ignore-invalid-entries
)
6990 :do
(setf ignore-invalid-p t
)
6992 :when
(funcall validator form
)
6995 :when ignore-invalid-p
6996 :do
(setf *ignored-configuration-form
* t
)
6998 :do
(report-invalid-form invalid-form-reporter
:form form
:location file
)))
6999 :inherit-configuration
)))
7001 (defun resolve-relative-location (x &key ensure-directory wilden
)
7002 "Given a designator X for an relative location, resolve it to a pathname."
7007 (string (parse-unix-namestring
7008 x
:ensure-directory ensure-directory
))
7011 (resolve-relative-location
7012 (car x
) :ensure-directory ensure-directory
:wilden wilden
)
7013 (let* ((car (resolve-relative-location
7014 (car x
) :ensure-directory t
:wilden nil
)))
7016 (resolve-relative-location
7017 (cdr x
) :ensure-directory ensure-directory
:wilden wilden
)
7019 ((eql :*/) *wild-directory
*)
7020 ((eql :**/) *wild-inferiors
*)
7021 ((eql :*.
*.
*) *wild-file
*)
7022 ((eql :implementation
)
7023 (parse-unix-namestring
7024 (implementation-identifier) :ensure-directory t
))
7025 ((eql :implementation-type
)
7026 (parse-unix-namestring
7027 (string-downcase (implementation-type)) :ensure-directory t
))
7029 (parse-unix-namestring (hostname) :ensure-directory t
)))
7030 :wilden
(and wilden
(not (pathnamep x
)) (not (member x
'(:*/ :**/ :*.
*.
*))))
7033 (defvar *here-directory
* nil
7034 "This special variable is bound to the currect directory during calls to
7035 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
7038 (defvar *user-cache
* nil
7039 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
7041 (defun resolve-absolute-location (x &key ensure-directory wilden
)
7042 "Given a designator X for an absolute location, resolve it to a pathname"
7048 (let ((p #-mcl
(parse-namestring x
)
7049 #+mcl
(probe-posix x
)))
7050 #+mcl
(unless p
(error "POSIX pathname ~S does not exist" x
))
7051 (if ensure-directory
(ensure-directory-pathname p
) p
)))
7053 (return-from resolve-absolute-location
7055 (resolve-absolute-location
7056 (car x
) :ensure-directory ensure-directory
:wilden wilden
)
7058 (resolve-relative-location
7059 (cdr x
) :ensure-directory ensure-directory
:wilden wilden
)
7060 (resolve-absolute-location
7061 (car x
) :ensure-directory t
:wilden nil
)))))
7063 ;; special magic! we return a relative pathname,
7064 ;; but what it means to the output-translations is
7065 ;; "relative to the root of the source pathname's host and device".
7066 (return-from resolve-absolute-location
7067 (let ((p (make-pathname :directory
'(:relative
))))
7068 (if wilden
(wilden p
) p
))))
7069 ((eql :home
) (user-homedir-pathname))
7070 ((eql :here
) (resolve-absolute-location
7071 (or *here-directory
* (pathname-directory-pathname (load-pathname)))
7072 :ensure-directory t
:wilden nil
))
7073 ((eql :user-cache
) (resolve-absolute-location
7074 *user-cache
* :ensure-directory t
:wilden nil
)))
7075 :wilden
(and wilden
(not (pathnamep x
)))
7076 :resolve-symlinks
*resolve-symlinks
*
7079 ;; Try to override declaration in previous versions of ASDF.
7080 (declaim (ftype (function (t &key
(:directory boolean
) (:wilden boolean
)
7081 (:ensure-directory boolean
)) t
) resolve-location
))
7083 (defun* (resolve-location) (x &key ensure-directory wilden directory
)
7084 "Resolve location designator X into a PATHNAME"
7085 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
7086 (loop* :with dirp
= (or directory ensure-directory
)
7087 :with
(first . rest
) = (if (atom x
) (list x
) x
)
7088 :with path
= (or (resolve-absolute-location
7089 first
:ensure-directory
(and (or dirp rest
) t
)
7090 :wilden
(and wilden
(null rest
)))
7092 :for
(element . morep
) :on rest
7093 :for dir
= (and (or morep dirp
) t
)
7094 :for wild
= (and wilden
(not morep
))
7095 :for sub
= (merge-pathnames*
7096 (resolve-relative-location
7097 element
:ensure-directory dir
:wilden wild
)
7099 :do
(setf path
(if (absolute-pathname-p sub
) (resolve-symlinks* sub
) sub
))
7100 :finally
(return path
)))
7102 (defun location-designator-p (x)
7103 "Is X a designator for a location?"
7104 ;; NIL means "skip this entry", or as an output translation, same as translation input.
7105 ;; T means "any input" for a translation, or as output, same as translation input.
7106 (flet ((absolute-component-p (c)
7107 (typep c
'(or string pathname
7108 (member :root
:home
:here
:user-cache
))))
7109 (relative-component-p (c)
7110 (typep c
'(or string pathname
7111 (member :*/ :**/ :*.
*.
* :implementation
:implementation-type
)))))
7112 (or (typep x
'boolean
)
7113 (absolute-component-p x
)
7114 (and (consp x
) (absolute-component-p (first x
)) (every #'relative-component-p
(rest x
))))))
7116 (defun location-function-p (x)
7117 "Is X the specification of a location function?"
7118 ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
7119 (and (length=n-p x
2) (eq (car x
) :function
)))
7121 (defvar *clear-configuration-hook
* '())
7123 (defun register-clear-configuration-hook (hook-function &optional call-now-p
)
7124 "Register a function to be called when clearing configuration"
7125 (register-hook-function '*clear-configuration-hook
* hook-function call-now-p
))
7127 (defun clear-configuration ()
7128 "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
7129 (call-functions *clear-configuration-hook
*))
7131 (register-image-dump-hook 'clear-configuration
)
7133 (defun upgrade-configuration ()
7134 "If a previous version of ASDF failed to read some configuration, try again now."
7135 (when *ignored-configuration-form
*
7136 (clear-configuration)
7137 (setf *ignored-configuration-form
* nil
)))
7140 (defun get-folder-path (folder)
7141 "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
7142 this function tries to locate the Windows FOLDER for one of
7143 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
7144 Returns NIL when the folder is not defined (e.g., not on Windows)."
7145 (or #+(and lispworks os-windows
) (sys:get-folder-path folder
)
7146 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
7148 (:local-appdata
(or (getenv-absolute-directory "LOCALAPPDATA")
7149 (subpathname* (get-folder-path :appdata
) "Local")))
7150 (:appdata
(getenv-absolute-directory "APPDATA"))
7151 (:common-appdata
(or (getenv-absolute-directory "ALLUSERSAPPDATA")
7152 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
7155 ;; Support for the XDG Base Directory Specification
7156 (defun xdg-data-home (&rest more
)
7157 "Returns an absolute pathname for the directory containing user-specific data files.
7158 MORE may contain specifications for a subpath relative to this directory: a
7159 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7160 also \"Configuration DSL\"\) in the ASDF manual."
7161 (resolve-absolute-location
7162 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
7164 ((os-windows-p) (get-folder-path :local-appdata
))
7165 (t (subpathname (user-homedir-pathname) ".local/share/"))))
7168 (defun xdg-config-home (&rest more
)
7169 "Returns a pathname for the directory containing user-specific configuration files.
7170 MORE may contain specifications for a subpath relative to this directory: a
7171 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7172 also \"Configuration DSL\"\) in the ASDF manual."
7173 (resolve-absolute-location
7174 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
7176 ((os-windows-p) (xdg-data-home "config/"))
7177 (t (subpathname (user-homedir-pathname) ".config/"))))
7180 (defun xdg-data-dirs (&rest more
)
7181 "The preference-ordered set of additional paths to search for data files.
7182 Returns a list of absolute directory pathnames.
7183 MORE may contain specifications for a subpath relative to these directories: a
7184 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7185 also \"Configuration DSL\"\) in the ASDF manual."
7186 (mapcar #'(lambda (d) (resolve-location `(,d
,more
)))
7187 (or (remove nil
(getenv-absolute-directories "XDG_DATA_DIRS"))
7189 ((os-windows-p) (mapcar 'get-folder-path
'(:appdata
:common-appdata
)))
7190 (t (mapcar 'parse-unix-namestring
'("/usr/local/share/" "/usr/share/")))))))
7192 (defun xdg-config-dirs (&rest more
)
7193 "The preference-ordered set of additional base paths to search for configuration files.
7194 Returns a list of absolute directory pathnames.
7195 MORE may contain specifications for a subpath relative to these directories:
7196 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7197 also \"Configuration DSL\"\) in the ASDF manual."
7198 (mapcar #'(lambda (d) (resolve-location `(,d
,more
)))
7199 (or (remove nil
(getenv-absolute-directories "XDG_CONFIG_DIRS"))
7201 ((os-windows-p) (xdg-data-dirs "config/"))
7202 (t (mapcar 'parse-unix-namestring
'("/etc/xdg/")))))))
7204 (defun xdg-cache-home (&rest more
)
7205 "The base directory relative to which user specific non-essential data files should be stored.
7206 Returns an absolute directory pathname.
7207 MORE may contain specifications for a subpath relative to this directory: a
7208 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7209 also \"Configuration DSL\"\) in the ASDF manual."
7210 (resolve-absolute-location
7211 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
7213 ((os-windows-p) (xdg-data-home "cache/"))
7214 (t (subpathname* (user-homedir-pathname) ".cache/"))))
7217 (defun xdg-runtime-dir (&rest more
)
7218 "Pathname for user-specific non-essential runtime files and other file objects,
7219 such as sockets, named pipes, etc.
7220 Returns an absolute directory pathname.
7221 MORE may contain specifications for a subpath relative to this directory: a
7222 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7223 also \"Configuration DSL\"\) in the ASDF manual."
7224 ;; The XDG spec says that if not provided by the login system, the application should
7225 ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
7226 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more
)))
7228 ;;; NOTE: modified the docstring because "system user configuration
7229 ;;; directories" seems self-contradictory. I'm not sure my wording is right.
7230 (defun system-config-pathnames (&rest more
)
7231 "Return a list of directories where are stored the system's default user configuration information.
7232 MORE may contain specifications for a subpath relative to these directories: a
7233 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7234 also \"Configuration DSL\"\) in the ASDF manual."
7235 (declare (ignorable more
))
7237 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more
))))))
7239 (defun filter-pathname-set (dirs)
7240 "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
7241 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs
) :from-end t
:test
'equal
))
7243 (defun xdg-data-pathnames (&rest more
)
7244 "Return a list of absolute pathnames for application data directories. With APP,
7245 returns directory for data for that application, without APP, returns the set of directories
7246 for storing all application configurations.
7247 MORE may contain specifications for a subpath relative to these directories: a
7248 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7249 also \"Configuration DSL\"\) in the ASDF manual."
7250 (filter-pathname-set
7251 `(,(xdg-data-home more
)
7252 ,@(xdg-data-dirs more
))))
7254 (defun xdg-config-pathnames (&rest more
)
7255 "Return a list of pathnames for application configuration.
7256 MORE may contain specifications for a subpath relative to these directories: a
7257 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7258 also \"Configuration DSL\"\) in the ASDF manual."
7259 (filter-pathname-set
7260 `(,(xdg-config-home more
)
7261 ,@(xdg-config-dirs more
))))
7263 (defun find-preferred-file (files &key
(direction :input
))
7264 "Find first file in the list of FILES that exists (for direction :input or :probe)
7265 or just the first one (for direction :output or :io).
7266 Note that when we say \"file\" here, the files in question may be directories."
7267 (find-if (ecase direction
((:probe
:input
) 'probe-file
*) ((:output
:io
) 'identity
)) files
))
7269 (defun xdg-data-pathname (&optional more
(direction :input
))
7270 (find-preferred-file (xdg-data-pathnames more
) :direction direction
))
7272 (defun xdg-config-pathname (&optional more
(direction :input
))
7273 (find-preferred-file (xdg-config-pathnames more
) :direction direction
))
7275 (defun compute-user-cache ()
7276 "Compute (and return) the location of the default user-cache for translate-output
7277 objects. Side-effects for cached file location computation."
7278 (setf *user-cache
* (xdg-cache-home "common-lisp" :implementation
)))
7279 (register-image-restore-hook 'compute-user-cache
))
7280 ;;; -------------------------------------------------------------------------
7281 ;;; Hacks for backward-compatibility with older versions of UIOP
7283 (uiop/package
:define-package
:uiop
/backward-driver
7284 (:recycle
:uiop
/backward-driver
:asdf
/backward-driver
:uiop
)
7285 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/version
7286 :uiop
/pathname
:uiop
/stream
:uiop
/os
:uiop
/image
7287 :uiop
/run-program
:uiop
/lisp-build
:uiop
/configuration
)
7290 #:user-configuration-directories
#:system-configuration-directories
7291 #:in-first-directory
#:in-user-configuration-directory
#:in-system-configuration-directory
7292 #:version-compatible-p
))
7293 (in-package :uiop
/backward-driver
)
7295 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
7296 (with-deprecation ((version-deprecation *uiop-version
* :style-warning
"3.2" :warning
"3.4"))
7297 ;; Backward compatibility with ASDF 2.000 to 2.26
7299 ;; For backward-compatibility only, for people using internals
7300 ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
7301 ;; Will be removed after 2015-12.
7302 (defun coerce-pathname (name &key type defaults
)
7303 "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead."
7304 (parse-unix-namestring name
:type type
:defaults defaults
))
7306 ;; Backward compatibility for ASDF 2.27 to 3.1.4
7307 (defun user-configuration-directories ()
7308 "Return the current user's list of user configuration directories
7309 for configuring common-lisp.
7310 DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
7311 (xdg-config-pathnames "common-lisp"))
7312 (defun system-configuration-directories ()
7313 "Return the list of system configuration directories for common-lisp.
7314 DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead."
7315 (system-config-pathnames "common-lisp"))
7316 (defun in-first-directory (dirs x
&key
(direction :input
))
7317 "Finds the first appropriate file named X in the list of DIRS for I/O
7318 in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
7319 If direction is :INPUT or :PROBE, will return the first extant file named
7320 X in one of the DIRS.
7321 If direction is :OUTPUT or :IO, will simply return the file named X in the
7322 first element of DIRS that exists. DEPRECATED."
7323 (find-preferred-file
7324 (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir
) x
)) dirs
)
7325 :direction direction
))
7326 (defun in-user-configuration-directory (x &key
(direction :input
))
7327 "Return the file named X in the user configuration directory for common-lisp.
7329 (xdg-config-pathname `("common-lisp" ,x
) direction
))
7330 (defun in-system-configuration-directory (x &key
(direction :input
))
7331 "Return the pathname for the file named X under the system configuration directory
7332 for common-lisp. DEPRECATED."
7333 (find-preferred-file (system-config-pathnames "common-lisp" x
) :direction direction
))
7336 ;; Backward compatibility with ASDF 1 to ASDF 2.32
7338 (defun version-compatible-p (provided-version required-version
)
7339 "Is the provided version a compatible substitution for the required-version?
7340 If major versions differ, it's not compatible.
7341 If they are equal, then any later version is compatible,
7342 with later being determined by a lexicographical comparison of minor numbers.
7344 (let ((x (parse-version provided-version nil
))
7345 (y (parse-version required-version nil
)))
7346 (and x y
(= (car x
) (car y
)) (lexicographic<= '< (cdr y
) (cdr x
)))))))
7348 ;;;; ---------------------------------------------------------------------------
7349 ;;;; Re-export all the functionality in UIOP
7351 (uiop/package
:define-package
:uiop
/driver
7352 (:nicknames
:uiop
:asdf
/driver
) ;; asdf/driver is obsolete (uiop isn't);
7353 ;; but asdf/driver is still used by swap-bytes, static-vectors.
7354 (:use
:uiop
/common-lisp
)
7355 ;; NB: not reexporting uiop/common-lisp
7356 ;; which include all of CL with compatibility modifications on select platforms,
7357 ;; that could cause potential conflicts for packages that would :use (cl uiop)
7358 ;; or :use (closer-common-lisp uiop), etc.
7360 :uiop
/package
:uiop
/utility
:uiop
/version
7361 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
7362 :uiop
/launch-program
:uiop
/run-program
7363 :uiop
/lisp-build
:uiop
/configuration
:uiop
/backward-driver
))
7365 ;; Provide both lowercase and uppercase, to satisfy more people.
7366 (provide "uiop") (provide "UIOP")
