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
)
4928 (stringp (simple-condition-format-control c
))
4930 "Couldn't grovel for "
4931 (simple-condition-format-control c
)
4932 " (unknown to the C compiler).")))
4933 (deftype sb-grovel-unknown-constant-condition
()
4934 '(and style-warning
(satisfies sb-grovel-unknown-constant-condition-p
))))
4936 (defvar *usual-uninteresting-conditions
*
4938 ;;#+clozure '(ccl:compiler-warning)
4939 #+cmucl
'("Deleting unreachable code.")
4940 #+lispworks
'("~S being redefined in ~A (previously in ~A)."
4941 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
4943 '(sb-c::simple-compiler-note
4944 "&OPTIONAL and &KEY found in the same lambda list: ~S"
4945 sb-kernel
:lexical-environment-too-complex
4946 sb-kernel
:undefined-alien-style-warning
4947 sb-grovel-unknown-constant-condition
; defined above.
4948 sb-ext
:implicit-generic-function-warning
;; Controversial.
4949 sb-int
:package-at-variance
4950 sb-kernel
:uninteresting-redefinition
4951 ;; BEWARE: the below four are controversial to include here.
4952 sb-kernel
:redefinition-with-defun
4953 sb-kernel
:redefinition-with-defgeneric
4954 sb-kernel
:redefinition-with-defmethod
4955 sb-kernel
::redefinition-with-defmacro
) ; not exported by old SBCLs
4956 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
4957 "A suggested value to which to set or bind *uninteresting-conditions*.")
4959 (defvar *uninteresting-conditions
* '()
4960 "Conditions that may be skipped while compiling or loading Lisp code.")
4961 (defvar *uninteresting-compiler-conditions
* '()
4962 "Additional conditions that may be skipped while compiling Lisp code.")
4963 (defvar *uninteresting-loader-conditions
*
4965 '("Overwriting already existing readtable ~S." ;; from named-readtables
4966 #(#:finalizers-off-warning
:asdf-finalizers
)) ;; from asdf-finalizers
4967 #+clisp
'(clos::simple-gf-replacing-method-warning
))
4968 "Additional conditions that may be skipped while loading Lisp code."))
4970 ;;;; ----- Filtering conditions while building -----
4971 (with-upgradability ()
4972 (defun call-with-muffled-compiler-conditions (thunk)
4973 "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
4974 (call-with-muffled-conditions
4975 thunk
(append *uninteresting-conditions
* *uninteresting-compiler-conditions
*)))
4976 (defmacro with-muffled-compiler-conditions
((&optional
) &body body
)
4977 "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
4978 `(call-with-muffled-compiler-conditions #'(lambda () ,@body
)))
4979 (defun call-with-muffled-loader-conditions (thunk)
4980 "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
4981 (call-with-muffled-conditions
4982 thunk
(append *uninteresting-conditions
* *uninteresting-loader-conditions
*)))
4983 (defmacro with-muffled-loader-conditions
((&optional
) &body body
)
4984 "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
4985 `(call-with-muffled-loader-conditions #'(lambda () ,@body
))))
4988 ;;;; Handle warnings and failures
4989 (with-upgradability ()
4990 (define-condition compile-condition
(condition)
4992 :initform nil
:reader compile-condition-context-format
:initarg
:context-format
)
4994 :initform nil
:reader compile-condition-context-arguments
:initarg
:context-arguments
)
4996 :initform nil
:reader compile-condition-description
:initarg
:description
))
4997 (:report
(lambda (c s
)
4998 (format s
(compatfmt "~@<~A~@[ while ~?~]~@:>")
4999 (or (compile-condition-description c
) (type-of c
))
5000 (compile-condition-context-format c
)
5001 (compile-condition-context-arguments c
)))))
5002 (define-condition compile-file-error
(compile-condition error
) ())
5003 (define-condition compile-warned-warning
(compile-condition warning
) ())
5004 (define-condition compile-warned-error
(compile-condition error
) ())
5005 (define-condition compile-failed-warning
(compile-condition warning
) ())
5006 (define-condition compile-failed-error
(compile-condition error
) ())
5008 (defun check-lisp-compile-warnings (warnings-p failure-p
5009 &optional context-format context-arguments
)
5010 "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
5011 raise an error or warning as appropriate"
5013 (case *compile-file-failure-behaviour
*
5014 (:warn
(warn 'compile-failed-warning
5015 :description
"Lisp compilation failed"
5016 :context-format context-format
5017 :context-arguments context-arguments
))
5018 (:error
(error 'compile-failed-error
5019 :description
"Lisp compilation failed"
5020 :context-format context-format
5021 :context-arguments context-arguments
))
5024 (case *compile-file-warnings-behaviour
*
5025 (:warn
(warn 'compile-warned-warning
5026 :description
"Lisp compilation had style-warnings"
5027 :context-format context-format
5028 :context-arguments context-arguments
))
5029 (:error
(error 'compile-warned-error
5030 :description
"Lisp compilation had style-warnings"
5031 :context-format context-format
5032 :context-arguments context-arguments
))
5035 (defun check-lisp-compile-results (output warnings-p failure-p
5036 &optional context-format context-arguments
)
5037 "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
5039 (error 'compile-file-error
:context-format context-format
:context-arguments context-arguments
))
5040 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments
)))
5043 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
5045 ;;; To support an implementation, three functions must be implemented:
5046 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
5047 ;;; See their respective docstrings.
5048 (with-upgradability ()
5049 (defun reify-simple-sexp (sexp)
5050 "Given a simple SEXP, return a representation of it as a portable SEXP.
5051 Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
5053 (symbol (reify-symbol sexp
))
5054 ((or number character simple-string pathname
) sexp
)
5055 (cons (cons (reify-simple-sexp (car sexp
)) (reify-simple-sexp (cdr sexp
))))
5056 (simple-vector (vector (mapcar 'reify-simple-sexp
(coerce sexp
'list
))))))
5058 (defun unreify-simple-sexp (sexp)
5059 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
5061 ((or symbol number character simple-string pathname
) sexp
)
5062 (cons (cons (unreify-simple-sexp (car sexp
)) (unreify-simple-sexp (cdr sexp
))))
5063 ((simple-vector 2) (unreify-symbol sexp
))
5064 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp
(aref sexp
0)) 'vector
))))
5068 (defun reify-source-note (source-note)
5070 (with-accessors ((source ccl
::source-note-source
) (filename ccl
:source-note-filename
)
5071 (start-pos ccl
:source-note-start-pos
) (end-pos ccl
:source-note-end-pos
)) source-note
5072 (declare (ignorable source
))
5073 (list :filename filename
:start-pos start-pos
:end-pos end-pos
5074 #|
:source
(reify-source-note source
)|
#))))
5075 (defun unreify-source-note (source-note)
5077 (destructuring-bind (&key filename start-pos end-pos source
) source-note
5078 (ccl::make-source-note
:filename filename
:start-pos start-pos
:end-pos end-pos
5079 :source
(unreify-source-note source
)))))
5080 (defun unsymbolify-function-name (name)
5081 (if-let (setfed (gethash name ccl
::%setf-function-name-inverses%
))
5084 (defun symbolify-function-name (name)
5085 (if (and (consp name
) (eq (first name
) 'setf
))
5086 (let ((setfed (second name
)))
5087 (gethash setfed ccl
::%setf-function-names%
))
5089 (defun reify-function-name (function-name)
5090 (let ((name (or (first function-name
) ;; defun: extract the name
5091 (let ((sec (second function-name
)))
5092 (or (and (atom sec
) sec
) ; scoped method: drop scope
5093 (first sec
)))))) ; method: keep gf name, drop method specializers
5095 (defun unreify-function-name (function-name)
5097 (defun nullify-non-literals (sexp)
5099 ((or number character simple-string symbol pathname
) sexp
)
5100 (cons (cons (nullify-non-literals (car sexp
))
5101 (nullify-non-literals (cdr sexp
))))
5103 (defun reify-deferred-warning (deferred-warning)
5104 (with-accessors ((warning-type ccl
::compiler-warning-warning-type
)
5105 (args ccl
::compiler-warning-args
)
5106 (source-note ccl
:compiler-warning-source-note
)
5107 (function-name ccl
:compiler-warning-function-name
)) deferred-warning
5108 (list :warning-type warning-type
:function-name
(reify-function-name function-name
)
5109 :source-note
(reify-source-note source-note
)
5110 :args
(destructuring-bind (fun &rest more
)
5112 (cons (unsymbolify-function-name fun
)
5113 (nullify-non-literals more
))))))
5114 (defun unreify-deferred-warning (reified-deferred-warning)
5115 (destructuring-bind (&key warning-type function-name source-note args
)
5116 reified-deferred-warning
5117 (make-condition (or (cdr (ccl::assq warning-type ccl
::*compiler-whining-conditions
*))
5118 'ccl
::compiler-warning
)
5119 :function-name
(unreify-function-name function-name
)
5120 :source-note
(unreify-source-note source-note
)
5121 :warning-type warning-type
5122 :args
(destructuring-bind (fun . more
) args
5123 (cons (symbolify-function-name fun
) more
))))))
5125 (defun reify-undefined-warning (warning)
5126 ;; Extracting undefined-warnings from the compilation-unit
5127 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5129 (c::undefined-warning-kind warning
)
5130 (c::undefined-warning-name warning
)
5131 (c::undefined-warning-count warning
)
5134 ;; the lexenv slot can be ignored for reporting purposes
5135 `(:enclosing-source
,(c::compiler-error-context-enclosing-source frob
)
5136 :source
,(c::compiler-error-context-source frob
)
5137 :original-source
,(c::compiler-error-context-original-source frob
)
5138 :context
,(c::compiler-error-context-context frob
)
5139 :file-name
,(c::compiler-error-context-file-name frob
) ; a pathname
5140 :file-position
,(c::compiler-error-context-file-position frob
) ; an integer
5141 :original-source-path
,(c::compiler-error-context-original-source-path frob
)))
5142 (c::undefined-warning-warnings warning
))))
5145 (defun reify-undefined-warning (warning)
5146 ;; Extracting undefined-warnings from the compilation-unit
5147 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5149 (sb-c::undefined-warning-kind warning
)
5150 (sb-c::undefined-warning-name warning
)
5151 (sb-c::undefined-warning-count warning
)
5154 ;; the lexenv slot can be ignored for reporting purposes
5155 `(:enclosing-source
,(sb-c::compiler-error-context-enclosing-source frob
)
5156 :source
,(sb-c::compiler-error-context-source frob
)
5157 :original-source
,(sb-c::compiler-error-context-original-source frob
)
5158 :context
,(sb-c::compiler-error-context-context frob
)
5159 :file-name
,(sb-c::compiler-error-context-file-name frob
) ; a pathname
5160 :file-position
,(sb-c::compiler-error-context-file-position frob
) ; an integer
5161 :original-source-path
,(sb-c::compiler-error-context-original-source-path frob
)))
5162 (sb-c::undefined-warning-warnings warning
))))
5164 (defun reify-deferred-warnings ()
5165 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
5166 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
5167 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
5169 (list :functions-defined excl
::.functions-defined.
5170 :functions-called excl
::.functions-called.
)
5172 (mapcar 'reify-deferred-warning
5173 (if-let (dw ccl
::*outstanding-deferred-warnings
*)
5174 (let ((mdw (ccl::ensure-merged-deferred-warnings dw
)))
5175 (ccl::deferred-warnings.warnings mdw
))))
5177 (when lisp
::*in-compilation-unit
*
5178 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5179 `(,@(when c
::*undefined-warnings
*
5180 `((c::*undefined-warnings
*
5181 ,@(mapcar #'reify-undefined-warning c
::*undefined-warnings
*))))
5182 ,@(loop :for what
:in
'(c::*compiler-error-count
*
5183 c
::*compiler-warning-count
*
5184 c
::*compiler-note-count
*)
5185 :for value
= (symbol-value what
)
5187 :collect
`(,what .
,value
))))
5189 (when sb-c
::*in-compilation-unit
*
5190 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5191 `(,@(when sb-c
::*undefined-warnings
*
5192 `((sb-c::*undefined-warnings
*
5193 ,@(mapcar #'reify-undefined-warning sb-c
::*undefined-warnings
*))))
5194 ,@(loop :for what
:in
'(sb-c::*aborted-compilation-unit-count
*
5195 sb-c
::*compiler-error-count
*
5196 sb-c
::*compiler-warning-count
*
5197 sb-c
::*compiler-style-warning-count
*
5198 sb-c
::*compiler-note-count
*)
5199 :for value
= (symbol-value what
)
5201 :collect
`(,what .
,value
)))))
5203 (defun unreify-deferred-warnings (reified-deferred-warnings)
5204 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
5205 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
5206 Handle any warning that has been resolved already,
5207 such as an undefined function that has been defined since.
5208 One of three functions required for deferred-warnings support in ASDF."
5209 (declare (ignorable reified-deferred-warnings
))
5211 (destructuring-bind (&key functions-defined functions-called
)
5212 reified-deferred-warnings
5213 (setf excl
::.functions-defined.
5214 (append functions-defined excl
::.functions-defined.
)
5215 excl
::.functions-called.
5216 (append functions-called excl
::.functions-called.
)))
5218 (let ((dw (or ccl
::*outstanding-deferred-warnings
*
5219 (setf ccl
::*outstanding-deferred-warnings
* (ccl::%defer-warnings t
)))))
5220 (appendf (ccl::deferred-warnings.warnings dw
)
5221 (mapcar 'unreify-deferred-warning reified-deferred-warnings
)))
5223 (dolist (item reified-deferred-warnings
)
5224 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5225 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5226 ;; For everything else, it's an integer.
5227 (destructuring-bind (symbol . adjustment
) item
5229 ((c::*undefined-warnings
*)
5230 (setf c
::*undefined-warnings
*
5233 (destructuring-bind (kind name count . rest
) stuff
5234 (unless (case kind
(:function
(fboundp name
)))
5236 (c::make-undefined-warning
5241 (mapcar #'(lambda (x)
5242 (apply #'c
::make-compiler-error-context x
))
5245 c
::*undefined-warnings
*)))
5247 (set symbol
(+ (symbol-value symbol
) adjustment
))))))
5249 (dolist (item reified-deferred-warnings
)
5250 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5251 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5252 ;; For everything else, it's an integer.
5253 (destructuring-bind (symbol . adjustment
) item
5255 ((sb-c::*undefined-warnings
*)
5256 (setf sb-c
::*undefined-warnings
*
5259 (destructuring-bind (kind name count . rest
) stuff
5260 (unless (case kind
(:function
(fboundp name
)))
5262 (sb-c::make-undefined-warning
5267 (mapcar #'(lambda (x)
5268 (apply #'sb-c
::make-compiler-error-context x
))
5271 sb-c
::*undefined-warnings
*)))
5273 (set symbol
(+ (symbol-value symbol
) adjustment
)))))))
5275 (defun reset-deferred-warnings ()
5276 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
5277 One of three functions required for deferred-warnings support in ASDF."
5279 (setf excl
::.functions-defined. nil
5280 excl
::.functions-called. nil
)
5282 (if-let (dw ccl
::*outstanding-deferred-warnings
*)
5283 (let ((mdw (ccl::ensure-merged-deferred-warnings dw
)))
5284 (setf (ccl::deferred-warnings.warnings mdw
) nil
)))
5286 (when lisp
::*in-compilation-unit
*
5287 (setf c
::*undefined-warnings
* nil
5288 c
::*compiler-error-count
* 0
5289 c
::*compiler-warning-count
* 0
5290 c
::*compiler-note-count
* 0))
5292 (when sb-c
::*in-compilation-unit
*
5293 (setf sb-c
::*undefined-warnings
* nil
5294 sb-c
::*aborted-compilation-unit-count
* 0
5295 sb-c
::*compiler-error-count
* 0
5296 sb-c
::*compiler-warning-count
* 0
5297 sb-c
::*compiler-style-warning-count
* 0
5298 sb-c
::*compiler-note-count
* 0)))
5300 (defun save-deferred-warnings (warnings-file)
5301 "Save forward reference conditions so they may be issued at a latter time,
5302 possibly in a different process."
5303 (with-open-file (s warnings-file
:direction
:output
:if-exists
:supersede
5304 :element-type
*default-stream-element-type
*
5305 :external-format
*utf-8-external-format
*)
5306 (with-safe-io-syntax ()
5307 (let ((*read-eval
* t
))
5308 (write (reify-deferred-warnings) :stream s
:pretty t
:readably t
))
5311 (defun warnings-file-type (&optional implementation-type
)
5312 "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
5313 where NIL designates the current one"
5314 (case (or implementation-type
*implementation-type
*)
5315 ((:acl
:allegro
) "allegro-warnings")
5316 ;;((:clisp) "clisp-warnings")
5317 ((:cmu
:cmucl
) "cmucl-warnings")
5318 ((:sbcl
) "sbcl-warnings")
5319 ((:clozure
:ccl
) "ccl-warnings")
5320 ((:scl
) "scl-warnings")))
5322 (defvar *warnings-file-type
* nil
5323 "Pathname type for warnings files, or NIL if disabled")
5325 (defun enable-deferred-warnings-check ()
5326 "Enable the saving of deferred warnings"
5327 (setf *warnings-file-type
* (warnings-file-type)))
5329 (defun disable-deferred-warnings-check ()
5330 "Disable the saving of deferred warnings"
5331 (setf *warnings-file-type
* nil
))
5333 (defun warnings-file-p (file &optional implementation-type
)
5334 "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
5335 If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
5336 (if-let (type (if implementation-type
5337 (warnings-file-type implementation-type
)
5338 *warnings-file-type
*))
5339 (equal (pathname-type file
) type
)))
5341 (defun check-deferred-warnings (files &optional context-format context-arguments
)
5342 "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
5343 re-intern and raise any warnings that are still meaningful."
5344 (let ((file-errors nil
)
5348 ((warning #'(lambda (c)
5350 (unless (typep c
'style-warning
)
5351 (setf failure-p t
)))))
5352 (with-compilation-unit (:override t
)
5353 (reset-deferred-warnings)
5354 (dolist (file files
)
5355 (unreify-deferred-warnings
5357 (with-safe-io-syntax ()
5358 (let ((*read-eval
* t
))
5359 (read-file-form file
)))
5361 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
5362 (push c file-errors
)
5364 (dolist (error file-errors
) (error error
))
5365 (check-lisp-compile-warnings
5366 (or failure-p warnings-p
) failure-p context-format context-arguments
)))
5369 Mini-guide to adding support for deferred warnings on an implementation.
5371 First
, look at what such a warning looks like
:
5375 (and (eval '(lambda () (some-undefined-function))) nil
)
5378 Then you can grep for the condition type in your compiler sources
5379 and see how to catch those that have been deferred
,
5380 and
/or read
, clear and restore the deferred list.
5383 (macroexpand-1 '(with-compilation-unit () foo
))
5386 (defun call-with-saved-deferred-warnings (thunk warnings-file
&key source-namestring
)
5387 "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
5388 and save those warnings to the given file for latter use,
5389 possibly in a different process. Otherwise just call THUNK."
5390 (declare (ignorable source-namestring
))
5392 (with-compilation-unit (:override t
#+sbcl
:source-namestring
#+sbcl source-namestring
)
5394 (let (#+sbcl
(sb-c::*undefined-warnings
* nil
))
5395 (multiple-value-prog1
5397 (save-deferred-warnings warnings-file
)))
5398 (reset-deferred-warnings)))
5401 (defmacro with-saved-deferred-warnings
((warnings-file &key source-namestring
) &body body
)
5402 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
5403 `(call-with-saved-deferred-warnings
5404 #'(lambda () ,@body
) ,warnings-file
:source-namestring
,source-namestring
)))
5408 (with-upgradability ()
5409 (defun current-lisp-file-pathname ()
5410 "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
5411 (or *compile-file-pathname
* *load-pathname
*))
5413 (defun load-pathname ()
5414 "Portably return the LOAD-PATHNAME of the current source file or fasl"
5415 *load-pathname
*) ;; magic no longer needed for GCL.
5417 (defun lispize-pathname (input-file)
5418 "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
5419 (make-pathname :type
"lisp" :defaults input-file
))
5421 (defun compile-file-type (&rest keys
)
5422 "pathname TYPE for lisp FASt Loading files"
5423 (declare (ignorable keys
))
5424 #-
(or clasp ecl mkcl
) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
5425 #+(or clasp ecl mkcl
) (pathname-type (apply 'compile-file-pathname
"foo" keys
)))
5427 (defun call-around-hook (hook function
)
5428 "Call a HOOK around the execution of FUNCTION"
5429 (call-function (or hook
'funcall
) function
))
5431 (defun compile-file-pathname* (input-file &rest keys
&key output-file
&allow-other-keys
)
5432 "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
5434 (remove-plist-keys `(#+(or (and allegro
(not (version>= 8 2)))) :external-format
5435 ,@(unless output-file
'(:output-file
))) keys
)))
5436 (if (absolute-pathname-p output-file
)
5437 ;; what cfp should be doing, w/ mp* instead of mp
5438 (let* ((type (pathname-type (apply 'compile-file-type keys
)))
5439 (defaults (make-pathname
5440 :type type
:defaults
(merge-pathnames* input-file
))))
5441 (merge-pathnames* output-file defaults
))
5442 (funcall *output-translation-function
*
5443 (apply 'compile-file-pathname input-file keys
)))))
5445 (defvar *compile-check
* nil
5446 "A hook for user-defined compile-time invariants")
5448 (defun* (compile-file*) (input-file &rest keys
5449 &key
(compile-check *compile-check
*) output-file warnings-file
5450 #+clisp lib-file
#+(or clasp ecl mkcl
) object-file
#+sbcl emit-cfasl
5452 "This function provides a portable wrapper around COMPILE-FILE.
5453 It ensures that the OUTPUT-FILE value is only returned and
5454 the file only actually created if the compilation was successful,
5455 even though your implementation may not do that. It also checks an optional
5456 user-provided consistency function COMPILE-CHECK to determine success;
5457 it will call this function if not NIL at the end of the compilation
5458 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
5459 where TMP-FILE is the name of a temporary output-file.
5460 It also checks two flags (with legacy british spelling from ASDF1),
5461 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
5462 with appropriate implementation-dependent defaults,
5463 and if a failure (respectively warnings) are reported by COMPILE-FILE,
5464 it will consider that an error unless the respective behaviour flag
5465 is one of :SUCCESS :WARN :IGNORE.
5466 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
5467 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
5468 On implementations that erroneously do not recognize standard keyword arguments,
5469 it will filter them appropriately."
5471 (when (and object-file
(equal (compile-file-type) (pathname object-file
)))
5472 (format t
"Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
5473 'compile-file
* output-file object-file
)
5474 (rotatef output-file object-file
))
5475 (let* ((keywords (remove-plist-keys
5476 `(:output-file
:compile-check
:warnings-file
5477 #+clisp
:lib-file
#+(or clasp ecl mkcl
) :object-file
) keys
))
5480 (apply 'compile-file-pathname
* input-file
:output-file output-file keywords
)))
5481 (physical-output-file (physicalize-pathname output-file
))
5484 (unless (use-ecl-byte-compiler-p)
5486 #+ecl
(compile-file-pathname output-file
:type
:object
)
5487 #+clasp
(compile-file-pathname output-file
:output-type
:object
))))
5491 (compile-file-pathname output-file
:fasl-p nil
)))
5492 (tmp-file (tmpize-pathname physical-output-file
))
5494 (cfasl-file (etypecase emit-cfasl
5496 ((eql t
) (make-pathname :type
"cfasl" :defaults physical-output-file
))
5497 (string (parse-namestring emit-cfasl
))
5498 (pathname emit-cfasl
)))
5500 (tmp-cfasl (when cfasl-file
(make-pathname :type
"cfasl" :defaults tmp-file
)))
5502 (tmp-lib (make-pathname :type
"lib" :defaults tmp-file
)))
5503 (multiple-value-bind (output-truename warnings-p failure-p
)
5504 (with-enough-pathname (input-file :defaults
*base-build-directory
*)
5505 (with-saved-deferred-warnings (warnings-file :source-namestring
(namestring input-file
))
5506 (with-muffled-compiler-conditions ()
5507 (or #-
(or clasp ecl mkcl
)
5508 (apply 'compile-file input-file
:output-file tmp-file
5509 #+sbcl
(if emit-cfasl
(list* :emit-cfasl tmp-cfasl keywords
) keywords
)
5511 #+ecl
(apply 'compile-file input-file
:output-file
5513 (list* object-file
:system-p t keywords
)
5514 (list* tmp-file keywords
)))
5515 #+clasp
(apply 'compile-file input-file
:output-file
5517 (list* object-file
:output-type
:object
#|
:system-p t|
# keywords
)
5518 (list* tmp-file keywords
)))
5519 #+mkcl
(apply 'compile-file input-file
5520 :output-file object-file
:fasl-p nil keywords
)))))
5522 ((and output-truename
5523 (flet ((check-flag (flag behaviour
)
5524 (or (not flag
) (member behaviour
'(:success
:warn
:ignore
)))))
5525 (and (check-flag failure-p
*compile-file-failure-behaviour
*)
5526 (check-flag warnings-p
*compile-file-warnings-behaviour
*)))
5528 #+(or clasp ecl mkcl
)
5529 (when (and #+(or clasp ecl
) object-file
)
5530 (setf output-truename
5531 (compiler::build-fasl tmp-file
5532 #+(or clasp ecl
) :lisp-files
#+mkcl
:lisp-object-files
(list object-file
))))
5533 (or (not compile-check
)
5534 (apply compile-check input-file
5535 :output-file output-truename
5537 (delete-file-if-exists physical-output-file
)
5538 (when output-truename
5539 #+clasp
(when output-truename
(rename-file-overwriting-target tmp-file output-truename
))
5540 ;; see CLISP bug 677
5543 (setf tmp-lib
(make-pathname :type
"lib" :defaults output-truename
))
5544 (unless lib-file
(setf lib-file
(make-pathname :type
"lib" :defaults physical-output-file
)))
5545 (rename-file-overwriting-target tmp-lib lib-file
))
5546 #+sbcl
(when cfasl-file
(rename-file-overwriting-target tmp-cfasl cfasl-file
))
5547 (rename-file-overwriting-target output-truename physical-output-file
)
5548 (setf output-truename
(truename physical-output-file
)))
5549 #+clasp
(delete-file-if-exists tmp-file
)
5550 #+clisp
(progn (delete-file-if-exists tmp-file
) ;; this one works around clisp BUG 677
5551 (delete-file-if-exists tmp-lib
))) ;; this one is "normal" defensive cleanup
5552 (t ;; error or failed check
5553 (delete-file-if-exists output-truename
)
5554 #+clisp
(delete-file-if-exists tmp-lib
)
5555 #+sbcl
(delete-file-if-exists tmp-cfasl
)
5556 (setf output-truename nil
)))
5557 (values output-truename warnings-p failure-p
))))
5559 (defun load* (x &rest keys
&key
&allow-other-keys
)
5560 "Portable wrapper around LOAD that properly handles loading from a stream."
5561 (with-muffled-loader-conditions ()
5563 ((or pathname string
#-
(or allegro clozure genera
) stream
#+clozure file-stream
)
5564 (apply 'load x keys
))
5565 ;; Genera can't load from a string-input-stream
5566 ;; ClozureCL 1.6 can only load from file input stream
5567 ;; Allegro 5, I don't remember but it must have been broken when I tested.
5568 #+(or allegro clozure genera
)
5569 (stream ;; make do this way
5570 (let ((*package
* *package
*)
5571 (*readtable
* *readtable
*)
5572 (*load-pathname
* nil
)
5573 (*load-truename
* nil
))
5576 (defun load-from-string (string)
5577 "Portably read and evaluate forms from a STRING."
5578 (with-input-from-string (s string
) (load* s
))))
5580 ;;; Links FASLs together
5581 (with-upgradability ()
5582 (defun combine-fasls (inputs output
)
5583 "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
5584 #-
(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl
)
5585 (not-implemented-error 'combine-fasls
"~%inputs: ~S~%output: ~S" inputs output
)
5586 #+abcl
(funcall 'sys
::concatenate-fasls inputs output
) ; requires ABCL 1.2.0
5587 #+(or allegro clisp cmucl sbcl scl xcl
) (concatenate-files inputs output
)
5588 #+clozure
(ccl:fasl-concatenate output inputs
:if-exists
:supersede
)
5593 (loop :for i
:in inputs
5595 :for f
= (add-pathname-suffix
5596 output
(format nil
"-FASL~D" n
))
5599 (ignore-errors (lispworks:delete-system
:fasls-to-concatenate
))
5600 (eval `(scm:defsystem
:fasls-to-concatenate
5601 (:default-pathname
,(pathname-directory-pathname output
))
5603 ,(loop :for f
:in
(reverse fasls
)
5604 :collect
`(,(namestring f
) :load-only t
))))
5605 (scm:concatenate-system output
:fasls-to-concatenate
:force t
))
5606 (loop :for f
:in fasls
:do
(ignore-errors (delete-file f
)))
5607 (ignore-errors (lispworks:delete-system
:fasls-to-concatenate
))))))
5608 ;;;; -------------------------------------------------------------------------
5609 ;;;; launch-program - semi-portably spawn asynchronous subprocesses
5611 (uiop/package
:define-package
:uiop
/launch-program
5612 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
5613 :uiop
/pathname
:uiop
/os
:uiop
/filesystem
:uiop
/stream
)
5615 ;;; Escaping the command invocation madness
5616 #:easy-sh-character-p
#:escape-sh-token
#:escape-sh-command
5617 #:escape-windows-token
#:escape-windows-command
5618 #:escape-shell-token
#:escape-shell-command
5619 #:escape-token
#:escape-command
5623 #:close-streams
#:process-alive-p
#:terminate-process
#:wait-process
5624 #:process-info-error-output
#:process-info-input
#:process-info-output
#:process-info-pid
))
5625 (in-package :uiop
/launch-program
)
5627 ;;;; ----- Escaping strings for the shell -----
5628 (with-upgradability ()
5629 (defun requires-escaping-p (token &key good-chars bad-chars
)
5630 "Does this token require escaping, given the specification of
5631 either good chars that don't need escaping or bad chars that do need escaping,
5632 as either a recognizing function or a sequence of characters."
5635 ((and good-chars bad-chars
)
5636 (parameter-error "~S: only one of good-chars and bad-chars can be provided"
5637 'requires-escaping-p
))
5638 ((typep good-chars
'function
)
5639 (complement good-chars
))
5640 ((typep bad-chars
'function
)
5642 ((and good-chars
(typep good-chars
'sequence
))
5643 #'(lambda (c) (not (find c good-chars
))))
5644 ((and bad-chars
(typep bad-chars
'sequence
))
5645 #'(lambda (c) (find c bad-chars
)))
5646 (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p
)))
5649 (defun escape-token (token &key stream quote good-chars bad-chars escaper
)
5650 "Call the ESCAPER function on TOKEN string if it needs escaping as per
5651 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
5652 using STREAM as output (or returning result as a string if NIL)"
5653 (if (requires-escaping-p token
:good-chars good-chars
:bad-chars bad-chars
)
5654 (with-output (stream)
5655 (apply escaper token stream
(when quote
`(:quote
,quote
))))
5656 (output-string token stream
)))
5658 (defun escape-windows-token-within-double-quotes (x &optional s
)
5659 "Escape a string token X within double-quotes
5660 for use within a MS Windows command-line, outputing to S."
5661 (labels ((issue (c) (princ c s
))
5662 (issue-backslash (n) (loop :repeat n
:do
(issue #\\))))
5664 :initially
(issue #\") :finally
(issue #\")
5665 :with l
= (length x
) :with i
= 0
5666 :for i
+1 = (1+ i
) :while
(< i l
) :do
5668 ((#\") (issue-backslash 1) (issue #\") (setf i i
+1))
5670 (let* ((j (and (< i
+1 l
) (position-if-not
5671 #'(lambda (c) (eql c
#\\)) x
:start i
+1)))
5675 (issue-backslash (* 2 n
)) (setf i l
))
5676 ((and (< j l
) (eql (char x j
) #\"))
5677 (issue-backslash (1+ (* 2 n
))) (issue #\") (setf i
(1+ j
)))
5679 (issue-backslash n
) (setf i j
)))))
5681 (issue (char x i
)) (setf i i
+1))))))
5683 (defun easy-windows-character-p (x)
5684 "Is X an \"easy\" character that does not require quoting by the shell?"
5685 (or (alphanumericp x
) (find x
"+-_.,@:/=")))
5687 (defun escape-windows-token (token &optional s
)
5688 "Escape a string TOKEN within double-quotes if needed
5689 for use within a MS Windows command-line, outputing to S."
5690 (escape-token token
:stream s
:good-chars
#'easy-windows-character-p
:quote nil
5691 :escaper
'escape-windows-token-within-double-quotes
))
5693 (defun escape-sh-token-within-double-quotes (x s
&key
(quote t
))
5694 "Escape a string TOKEN within double-quotes
5695 for use within a POSIX Bourne shell, outputing to S;
5696 omit the outer double-quotes if key argument :QUOTE is NIL"
5697 (when quote
(princ #\" s
))
5698 (loop :for c
:across x
:do
5699 (when (find c
"$`\\\"") (princ #\\ s
))
5701 (when quote
(princ #\" s
)))
5703 (defun easy-sh-character-p (x)
5704 "Is X an \"easy\" character that does not require quoting by the shell?"
5705 (or (alphanumericp x
) (find x
"+-_.,%@:/=")))
5707 (defun escape-sh-token (token &optional s
)
5708 "Escape a string TOKEN within double-quotes if needed
5709 for use within a POSIX Bourne shell, outputing to S."
5710 (escape-token token
:stream s
:quote
#\" :good-chars
#'easy-sh-character-p
5711 :escaper
'escape-sh-token-within-double-quotes
))
5713 (defun escape-shell-token (token &optional s
)
5714 "Escape a token for the current operating system shell"
5716 ((os-unix-p) (escape-sh-token token s
))
5717 ((os-windows-p) (escape-windows-token token s
))))
5719 (defun escape-command (command &optional s
5720 (escaper 'escape-shell-token
))
5721 "Given a COMMAND as a list of tokens, return a string of the
5722 spaced, escaped tokens, using ESCAPER to escape."
5724 (string (output-string command s
))
5725 (list (with-output (s)
5726 (loop :for first
= t
:then nil
:for token
:in command
:do
5727 (unless first
(princ #\space s
))
5728 (funcall escaper token s
))))))
5730 (defun escape-windows-command (command &optional s
)
5731 "Escape a list of command-line arguments into a string suitable for parsing
5732 by CommandLineToArgv in MS Windows"
5733 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
5734 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
5735 (escape-command command s
'escape-windows-token
))
5737 (defun escape-sh-command (command &optional s
)
5738 "Escape a list of command-line arguments into a string suitable for parsing
5739 by /bin/sh in POSIX"
5740 (escape-command command s
'escape-sh-token
))
5742 (defun escape-shell-command (command &optional stream
)
5743 "Escape a command for the current operating system's shell"
5744 (escape-command command stream
'escape-shell-token
)))
5747 (with-upgradability ()
5748 ;;; Internal helpers for run-program
5749 (defun %normalize-io-specifier
(specifier &optional role
)
5750 "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
5751 argument to pass to the internal RUN-PROGRAM"
5752 (declare (ignorable role
))
5754 (null (or #+(or allegro lispworks
) (null-device-pathname)))
5755 (string (parse-native-namestring specifier
))
5756 (pathname specifier
)
5758 ((eql :stream
) :stream
)
5760 #+(or allegro lispworks
) nil
5762 #+(or abcl clozure cmucl ecl mkcl sbcl scl
) t
5763 #-
(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp
)
5764 (not-implemented-error :interactive-output
5765 "On this lisp implementation, cannot interpret ~a value of ~a"
5768 (cond ((eq role
:error-output
)
5769 #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5771 #-
(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5772 (not-implemented-error :error-output-redirect
5773 "Can't send ~a to ~a on this lisp implementation."
5775 (t (parameter-error "~S IO specifier invalid for ~S" specifier role
))))
5777 (parameter-error "Incorrect I/O specifier ~S for ~S"
5780 (defun %interactivep
(input output error-output
)
5781 (member :interactive
(list input output error-output
)))
5783 (defun %signal-to-exit-code
(signum)
5786 (defun %code-to-status
(exit-code signal-code
)
5787 (cond ((null exit-code
) :running
)
5788 ((null signal-code
) (values :exited exit-code
))
5789 (t (values :signaled signal-code
))))
5792 (defun %mkcl-signal-to-number
(signal)
5794 (symbol-value (find-symbol signal
:mk-unix
)))
5796 (defclass process-info
()
5797 (;; The process field is highly platform-, implementation-, and
5798 ;; even version-dependent.
5799 ;; Prior to LispWorks 7, the only information that
5800 ;; `sys:run-shell-command` with `:wait nil` was certain to return
5801 ;; is a PID (e.g. when all streams are nil), hence we stored it
5802 ;; and used `sys:pid-exit-status` to obtain an exit status
5803 ;; later. That is still what we do.
5804 ;; From LispWorks 7 on, if `sys:run-shell-command` does not
5805 ;; return a proper stream, we are instead given a dummy stream.
5806 ;; We can thus always store a stream and use
5807 ;; `sys:pipe-exit-status` to obtain an exit status later.
5808 ;; The advantage of dealing with streams instead of PID is the
5809 ;; availability of functions like `sys:pipe-kill-process`.
5810 (process :initform nil
)
5811 (input-stream :initform nil
)
5812 (output-stream :initform nil
)
5813 (bidir-stream :initform nil
)
5814 (error-output-stream :initform nil
)
5815 ;; For backward-compatibility, to maintain the property (zerop
5816 ;; exit-code) <-> success, an exit in response to a signal is
5817 ;; encoded as 128+signum.
5818 (exit-code :initform nil
)
5819 ;; If the platform allows it, distinguish exiting with a code
5820 ;; >128 from exiting in response to a signal by setting this code
5821 (signal-code :initform nil
)))
5823 ;;;---------------------------------------------------------------------------
5824 ;;; The following two helper functions take care of handling the IF-EXISTS and
5825 ;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
5826 ;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
5827 ;;; function to treat input and output files unconditionally for reading and
5829 ;;;---------------------------------------------------------------------------
5831 (defun %handle-if-exists
(file if-exists
)
5832 (when (or (stringp file
) (pathnamep file
))
5834 ((:append
:supersede
:error
)
5835 (with-open-file (dummy file
:direction
:output
:if-exists if-exists
)
5836 (declare (ignorable dummy
)))))))
5838 (defun %handle-if-does-not-exist
(file if-does-not-exist
)
5839 (when (or (stringp file
) (pathnamep file
))
5840 (ecase if-does-not-exist
5842 (with-open-file (dummy file
:direction
:probe
5843 :if-does-not-exist if-does-not-exist
)
5844 (declare (ignorable dummy
)))))))
5846 (defun process-info-error-output (process-info)
5847 (slot-value process-info
'error-output-stream
))
5848 (defun process-info-input (process-info)
5849 (or (slot-value process-info
'bidir-stream
)
5850 (slot-value process-info
'input-stream
)))
5851 (defun process-info-output (process-info)
5852 (or (slot-value process-info
'bidir-stream
)
5853 (slot-value process-info
'output-stream
)))
5855 (defun process-info-pid (process-info)
5856 (let ((process (slot-value process-info
'process
)))
5857 (declare (ignorable process
))
5858 #+abcl
(symbol-call :sys
:process-pid process
)
5860 #+clozure
(ccl:external-process-id process
)
5861 #+ecl
(ext:external-process-pid process
)
5862 #+(or cmucl scl
) (ext:process-pid process
)
5863 #+lispworks7
+ (sys:pipe-pid process
)
5864 #+(and lispworks
(not lispworks7
+)) process
5865 #+mkcl
(mkcl:process-id process
)
5866 #+sbcl
(sb-ext:process-pid process
)
5867 #-
(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl
)
5868 (not-implemented-error 'process-info-pid
)))
5870 (defun %process-status
(process-info)
5871 (if-let (exit-code (slot-value process-info
'exit-code
))
5872 (return-from %process-status
5873 (if-let (signal-code (slot-value process-info
'signal-code
))
5874 (values :signaled signal-code
)
5875 (values :exited exit-code
))))
5876 #-
(or allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5877 (not-implemented-error '%process-status
)
5878 (if-let (process (slot-value process-info
'process
))
5879 (multiple-value-bind (status code
)
5881 #+allegro
(multiple-value-bind (exit-code pid signal-code
)
5882 (sys:reap-os-subprocess
:pid process
:wait nil
)
5884 (%code-to-status exit-code signal-code
))
5885 #+clozure
(ccl:external-process-status process
)
5886 #+(or cmucl scl
) (let ((status (ext:process-status process
)))
5887 (if (member status
'(:exited
:signaled
))
5888 ;; Calling ext:process-exit-code on
5889 ;; processes that are still alive
5890 ;; yields an undefined result
5891 (values status
(ext:process-exit-code process
))
5893 #+ecl
(ext:external-process-status process
)
5895 ;; a signal is only returned on LispWorks 7+
5896 (multiple-value-bind (exit-code signal-code
)
5898 #+lispworks7
+ :pipe-exit-status
5899 #-lispworks7
+ :pid-exit-status
5901 (%code-to-status exit-code signal-code
))
5902 #+mkcl
(let ((status (mk-ext:process-status process
)))
5903 (if (eq status
:exited
)
5904 ;; Only call mk-ext:process-exit-code when
5905 ;; necessary since it leads to another waitpid()
5906 (let ((code (mk-ext:process-exit-code process
)))
5908 (values :signaled
(%mkcl-signal-to-number code
))
5909 (values :exited code
)))
5911 #+sbcl
(let ((status (sb-ext:process-status process
)))
5912 (if (eq status
:running
)
5914 ;; sb-ext:process-exit-code can also be
5915 ;; called for stopped processes to determine
5916 ;; the signal that stopped them
5917 (values status
(sb-ext:process-exit-code process
)))))
5919 (:exited
(setf (slot-value process-info
'exit-code
) code
))
5920 (:signaled
(let ((%code
(%signal-to-exit-code code
)))
5921 (setf (slot-value process-info
'exit-code
) %code
5922 (slot-value process-info
'signal-code
) code
))))
5924 (values status code
)
5927 (defun process-alive-p (process-info)
5928 "Check if a process has yet to exit."
5929 (unless (slot-value process-info
'exit-code
)
5930 #+abcl
(sys:process-alive-p
(slot-value process-info
'process
))
5931 #+(or cmucl scl
) (ext:process-alive-p
(slot-value process-info
'process
))
5932 #+sbcl
(sb-ext:process-alive-p
(slot-value process-info
'process
))
5933 #-
(or abcl cmucl sbcl scl
) (find (%process-status process-info
)
5934 '(:running
:stopped
:continued
:resumed
))))
5936 (defun wait-process (process-info)
5937 "Wait for the process to terminate, if it is still running.
5938 Otherwise, return immediately. An exit code (a number) will be
5939 returned, with 0 indicating success, and anything else indicating
5940 failure. If the process exits after receiving a signal, the exit code
5941 will be the sum of 128 and the (positive) numeric signal code. A second
5942 value may be returned in this case: the numeric signal code itself.
5943 Any asynchronously spawned process requires this function to be run
5944 before it is garbage-collected in order to free up resources that
5945 might otherwise be irrevocably lost."
5946 (if-let (exit-code (slot-value process-info
'exit-code
))
5947 (if-let (signal-code (slot-value process-info
'signal-code
))
5948 (values exit-code signal-code
)
5950 (let ((process (slot-value process-info
'process
)))
5951 #-
(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl
)
5952 (not-implemented-error 'wait-process
)
5955 #+clozure
(ccl::external-process-wait process
)
5956 #+(or cmucl scl
) (ext:process-wait process
)
5957 #+sbcl
(sb-ext:process-wait process
)
5958 ;; 2- extract result
5959 (multiple-value-bind (exit-code signal-code
)
5961 #+abcl
(sys:process-wait process
)
5962 #+allegro
(multiple-value-bind (exit-code pid signal
)
5963 (sys:reap-os-subprocess
:pid process
:wait t
)
5965 (values exit-code signal
))
5966 #+clozure
(multiple-value-bind (status code
)
5967 (ccl:external-process-status process
)
5968 (if (eq status
:signaled
)
5971 #+(or cmucl scl
) (let ((status (ext:process-status process
))
5972 (code (ext:process-exit-code process
)))
5973 (if (eq status
:signaled
)
5976 #+ecl
(multiple-value-bind (status code
)
5977 (ext:external-process-wait process t
)
5978 (if (eq status
:signaled
)
5981 #+lispworks
(symbol-call :sys
5982 #+lispworks7
+ :pipe-exit-status
5983 #-lispworks7
+ :pid-exit-status
5985 #+mkcl
(let ((code (mkcl:join-process process
)))
5987 (values nil
(%mkcl-signal-to-number code
))
5989 #+sbcl
(let ((status (sb-ext:process-status process
))
5990 (code (sb-ext:process-exit-code process
)))
5991 (if (eq status
:signaled
)
5995 (let ((%exit-code
(%signal-to-exit-code signal-code
)))
5996 (setf (slot-value process-info
'exit-code
) %exit-code
5997 (slot-value process-info
'signal-code
) signal-code
)
5998 (values %exit-code signal-code
))
5999 (progn (setf (slot-value process-info
'exit-code
) exit-code
)
6002 ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
6003 ;; do what you expect it to. Sending SIGSTOP to a process spawned
6004 ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
6005 ;; to run the command (via `sh -c command`) but not the actual
6008 (defun %posix-send-signal
(process-info signal
)
6009 #+allegro
(excl.osi
:kill
(slot-value process-info
'process
) signal
)
6010 #+clozure
(ccl:signal-external-process
(slot-value process-info
'process
)
6011 signal
:error-if-exited nil
)
6012 #+(or cmucl scl
) (ext:process-kill
(slot-value process-info
'process
) signal
)
6013 #+sbcl
(sb-ext:process-kill
(slot-value process-info
'process
) signal
)
6014 #-
(or allegro clozure cmucl sbcl scl
)
6015 (if-let (pid (process-info-pid process-info
))
6016 (symbol-call :uiop
:run-program
6017 (format nil
"kill -~a ~a" signal pid
) :ignore-error-status t
)))
6019 ;;; this function never gets called on Windows, but the compiler cannot tell
6020 ;;; that. [2016/09/25:rpg]
6022 (defun %posix-send-signal
(process-info signal
)
6023 (declare (ignore process-info signal
))
6026 (defun terminate-process (process-info &key urgent
)
6027 "Cause the process to exit. To that end, the process may or may
6028 not be sent a signal, which it will find harder (or even impossible)
6029 to ignore if URGENT is T. On some platforms, it may also be subject to
6031 (declare (ignorable urgent
))
6032 #+abcl
(sys:process-kill
(slot-value process-info
'process
))
6033 ;; On ECL, this will only work on versions later than 2016-09-06,
6034 ;; but we still want to compile on earlier versions, so we use symbol-call
6035 #+ecl
(symbol-call :ext
:terminate-process
(slot-value process-info
'process
) urgent
)
6036 #+lispworks7
+ (sys:pipe-kill-process
(slot-value process-info
'process
))
6037 #+mkcl
(mk-ext:terminate-process
(slot-value process-info
'process
)
6039 #-
(or abcl ecl lispworks7
+ mkcl
)
6041 ((os-unix-p) (%posix-send-signal process-info
(if urgent
9 15)))
6042 ((os-windows-p) (if-let (pid (process-info-pid process-info
))
6043 (symbol-call :uiop
:run-program
6044 (format nil
"taskkill ~:[~;/f ~]/pid ~a" urgent pid
)
6045 :ignore-error-status t
)))
6046 (t (not-implemented-error 'terminate-process
))))
6048 (defun close-streams (process-info)
6049 "Close any stream that the process might own. Needs to be run
6050 whenever streams were requested by passing :stream to :input, :output,
6053 (cons (slot-value process-info
'error-output-stream
)
6054 (if-let (bidir-stream (slot-value process-info
'bidir-stream
))
6056 (list (slot-value process-info
'input-stream
)
6057 (slot-value process-info
'output-stream
)))))
6058 (when stream
(close stream
))))
6060 (defun launch-program (command &rest keys
6062 input
(if-input-does-not-exist :error
)
6063 output
(if-output-exists :supersede
)
6064 error-output
(if-error-output-exists :supersede
)
6065 (element-type #-clozure
*default-stream-element-type
*
6066 #+clozure
'character
)
6067 (external-format *utf-8-external-format
*)
6069 #+allegro separate-streams
6071 "Launch program specified by COMMAND,
6072 either a list of strings specifying a program and list of arguments,
6073 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
6074 Windows) _asynchronously_.
6076 If OUTPUT is a pathname, a string designating a pathname, or NIL (the
6077 default) designating the null device, the file at that path is used as
6079 If it's :INTERACTIVE, output is inherited from the current process;
6080 beware that this may be different from your *STANDARD-OUTPUT*, and
6081 under SLIME will be on your *inferior-lisp* buffer. If it's T, output
6082 goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
6083 stream will be made available that can be accessed via
6084 PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
6085 that the underlying lisp implementation knows how to handle.
6087 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
6088 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
6089 default). The meaning of these values and their effect on the case
6090 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
6091 to OPEN with :DIRECTION :OUTPUT.
6093 ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
6094 :OUTPUT means redirecting the error output to the output stream,
6095 and :STREAM causes a stream to be made available via
6096 PROCESS-INFO-ERROR-OUTPUT.
6098 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
6099 affects ERROR-OUTPUT rather than OUTPUT.
6101 INPUT is similar to OUTPUT, except that T designates the
6102 *STANDARD-INPUT* and a stream requested through the :STREAM keyword
6103 would be available through PROCESS-INFO-INPUT.
6105 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
6106 or a pathname, can take the values :CREATE and :ERROR (the
6107 default). The meaning of these values is analogous to the
6108 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
6110 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
6111 implementation, when applicable, for creation of the output stream.
6113 LAUNCH-PROGRAM returns a PROCESS-INFO object."
6114 #-
(or abcl allegro clozure cmucl ecl
(and lispworks os-unix
) mkcl sbcl scl
)
6115 (progn command keys input output error-output directory element-type external-format
6116 if-input-does-not-exist if-output-exists if-error-output-exists
;; ignore
6117 (not-implemented-error 'launch-program
))
6119 (when (some #'(lambda (stream)
6120 (and (streamp stream
)
6121 (not (file-stream-p stream
))))
6122 (list input output error-output
))
6123 (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
6125 #+(or abcl clisp lispworks
)
6126 (when (some #'streamp
(list input output error-output
))
6127 (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
6130 (unless (eq error-output
:interactive
)
6131 (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
6132 'launch-program
:error-output
:interactive
))
6134 (when (some #'(lambda (stream)
6135 (and (streamp stream
)
6136 (not (file-or-synonym-stream-p stream
))))
6137 (list input output error-output
))
6138 (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
6140 #+(or abcl allegro clozure cmucl ecl
(and lispworks os-unix
) mkcl sbcl scl
)
6142 (progn ;; see comments for these functions
6143 (%handle-if-does-not-exist input if-input-does-not-exist
)
6144 (%handle-if-exists output if-output-exists
)
6145 (%handle-if-exists error-output if-error-output-exists
))
6146 #+ecl
(let ((*standard-input
* *stdin
*)
6147 (*standard-output
* *stdout
*)
6148 (*error-output
* *stderr
*)))
6149 (let ((process-info (make-instance 'process-info
))
6150 (input (%normalize-io-specifier input
:input
))
6151 (output (%normalize-io-specifier output
:output
))
6152 (error-output (%normalize-io-specifier error-output
:error-output
))
6153 #+(and allegro os-windows
) (interactive (%interactivep input output error-output
))
6156 #+os-unix
(string `("/bin/sh" "-c" ,command
))
6157 #+os-unix
(list command
)
6160 ;; NB: On other Windows implementations, this is utterly bogus
6161 ;; except in the most trivial cases where no quoting is needed.
6162 ;; Use at your own risk.
6163 #-
(or allegro clisp clozure ecl
)
6165 #+(or ecl sbcl
) (unless (find-symbol* :escape-arguments
#+ecl
:ext
#+sbcl
:sb-impl nil
))
6166 (parameter-error "~S doesn't support string commands on Windows on this Lisp"
6167 'launch-program command
))
6168 ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
6169 ;; when the command contains spaces or special characters:
6170 ;; IIUC, the system will use space as a separator,
6171 ;; but the C++ argv-decoding libraries won't, and
6172 ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
6173 ;; yet neither allegro nor clisp provide access to that argument.
6174 #+(or allegro clisp
) (strcat "cmd /c " command
)
6175 ;; On ClozureCL for Windows, we assume you are using
6176 ;; r15398 or later in 1.9 or later,
6177 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
6178 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
6179 ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
6180 #+(or clozure ecl sbcl
) (cons "cmd" (strcat "/c " command
)))
6183 #+allegro
(escape-windows-command command
)
6184 #-allegro command
)))))
6185 #+(or abcl
(and allegro os-unix
) clozure cmucl ecl mkcl sbcl
)
6186 (let ((program (car command
))
6187 #-allegro
(arguments (cdr command
))))
6188 #+(and (or ecl sbcl
) os-windows
)
6189 (multiple-value-bind (arguments escape-arguments
)
6190 (if (listp arguments
)
6191 (values arguments t
)
6192 (values (list arguments
) nil
)))
6193 #-
(or allegro mkcl sbcl
) (with-current-directory (directory))
6194 (multiple-value-bind
6195 #+(or abcl clozure cmucl sbcl scl
) (process)
6196 #+allegro
(in-or-io out-or-err err-or-pid pid-or-nil
)
6197 #+ecl
(stream code process
)
6198 #+lispworks
(io-or-pid err-or-nil
#-lispworks7
+ pid-or-nil
)
6199 #+mkcl
(stream process code
)
6201 #+abcl
'sys
:run-program
6202 #+allegro
,@'('excl
:run-shell-command
6203 #+os-unix
(coerce (cons program command
) 'vector
)
6204 #+os-windows command
)
6205 #+clozure
'ccl
:run-program
6206 #+(or cmucl ecl scl
) 'ext
:run-program
6207 #+lispworks
,@'('system
:run-shell-command
`("/usr/bin/env" ,@command
)) ; full path needed
6208 #+mkcl
'mk-ext
:run-program
6209 #+sbcl
'sb-ext
:run-program
6210 #+(or abcl clozure cmucl ecl mkcl sbcl
) ,@'(program arguments
)
6211 #+(and (or ecl sbcl
) os-windows
) ,@'(:escape-arguments escape-arguments
)
6212 :input input
:if-input-does-not-exist
:error
6213 :output output
:if-output-exists
:append
6214 ,(or #+(or allegro lispworks
) :error-output
:error
) error-output
6215 ,(or #+(or allegro lispworks
) :if-error-output-exists
:if-error-exists
) :append
6216 :wait nil
:element-type element-type
:external-format external-format
6218 #+allegro
,@`(:directory directory
6219 #+os-windows
,@'(:show-window
(if interactive nil
:hide
)))
6220 #+lispworks
,@'(:save-exit-status t
)
6221 #+mkcl
,@'(:directory
(native-namestring directory
))
6222 #-sbcl keys
;; on SBCL, don't pass :directory nil but remove it from the keys
6223 #+sbcl
,@'(:search t
(if directory keys
(remove-plist-key :directory keys
)))))
6224 (labels ((prop (key value
) (setf (slot-value process-info key
) value
)))
6228 (prop 'process pid-or-nil
)
6229 (when (eq input
:stream
) (prop 'input-stream in-or-io
))
6230 (when (eq output
:stream
) (prop 'output-stream out-or-err
))
6231 (when (eq error-output
:stream
) (prop 'error-stream err-or-pid
)))
6233 (prop 'process err-or-pid
)
6234 (ecase (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))
6236 (1 (prop 'input-stream in-or-io
))
6237 (2 (prop 'output-stream in-or-io
))
6238 (3 (prop 'bidir-stream in-or-io
)))
6239 (when (eq error-output
:stream
)
6240 (prop 'error-stream out-or-err
))))
6241 #+(or abcl clozure cmucl sbcl scl
)
6243 (prop 'process process
)
6244 (when (eq input
:stream
)
6246 (prop 'input-stream
)
6247 #+abcl
(symbol-call :sys
:process-input
)
6248 #+clozure
(ccl:external-process-input-stream
)
6249 #+(or cmucl scl
) (ext:process-input
)
6250 #+sbcl
(sb-ext:process-input
)
6252 (when (eq output
:stream
)
6254 (prop 'output-stream
)
6255 #+abcl
(symbol-call :sys
:process-output
)
6256 #+clozure
(ccl:external-process-output-stream
)
6257 #+(or cmucl scl
) (ext:process-output
)
6258 #+sbcl
(sb-ext:process-output
)
6260 (when (eq error-output
:stream
)
6262 (prop 'error-output-stream
)
6263 #+abcl
(symbol-call :sys
:process-error
)
6264 #+clozure
(ccl:external-process-error-stream
)
6265 #+(or cmucl scl
) (ext:process-error
)
6266 #+sbcl
(sb-ext:process-error
)
6269 (let ((mode (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))))
6271 (unless (zerop mode
)
6272 (prop (case mode
(1 'input-stream
) (2 'output-stream
) (3 'bidir-stream
)) stream
))
6273 (prop 'process process
))
6275 ;; See also the comments on the process-info class
6276 (let ((mode (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))))
6278 ((or (plusp mode
) (eq error-output
:stream
))
6279 (prop 'process
#+lispworks7
+ io-or-pid
#-lispworks7
+ pid-or-nil
)
6281 (prop (ecase mode
(1 'input-stream
) (2 'output-stream
) (3 'bidir-stream
))
6283 (when (eq error-output
:stream
)
6284 (prop 'error-stream err-or-nil
)))
6285 ;; Prior to Lispworks 7, this returned (pid); now it
6286 ;; returns (io err pid) of which we keep io.
6287 (t (prop 'process io-or-pid
)))))
6290 ;;;; -------------------------------------------------------------------------
6291 ;;;; run-program initially from xcvb-driver.
6293 (uiop/package
:define-package
:uiop
/run-program
6294 (:nicknames
:asdf
/run-program
) ; OBSOLETE. Used by cl-sane, printv.
6295 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/version
6296 :uiop
/pathname
:uiop
/os
:uiop
/filesystem
:uiop
/stream
:uiop
/launch-program
)
6299 #:slurp-input-stream
#:vomit-output-stream
6301 #:subprocess-error-code
#:subprocess-error-command
#:subprocess-error-process
)
6302 (:import-from
:uiop
/launch-program
6303 #:%handle-if-does-not-exist
#:%handle-if-exists
#:%interactivep
6304 #:input-stream
#:output-stream
#:error-output-stream
))
6305 (in-package :uiop
/run-program
)
6307 ;;;; Slurping a stream, typically the output of another program
6308 (with-upgradability ()
6309 (defun call-stream-processor (fun processor stream
)
6310 "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
6311 a PROCESSOR specification which is either an atom or a list specifying
6312 a processor an keyword arguments, call the specified processor with
6313 the given STREAM as input"
6314 (if (consp processor
)
6315 (apply fun
(first processor
) stream
(rest processor
))
6316 (funcall fun processor stream
)))
6318 (defgeneric slurp-input-stream
(processor input-stream
&key
)
6320 "SLURP-INPUT-STREAM is a generic function with two positional arguments
6321 PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
6322 the contents of the INPUT-STREAM and processes them according to a method
6323 specified by PROCESSOR.
6325 Built-in methods include the following:
6326 * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
6327 * if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
6328 INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
6329 \(APPLY x <stream> y\)
6330 * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
6331 per copy-stream-to-stream, with appropriate keyword arguments.
6332 * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
6333 are returned as a string, as per SLURP-STREAM-STRING.
6334 * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
6335 * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
6336 * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
6337 * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
6338 * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
6340 Programmers are encouraged to define their own methods for this generic function."))
6343 (defmethod slurp-input-stream ((function function
) input-stream
&key
)
6344 (funcall function input-stream
))
6346 (defmethod slurp-input-stream ((list cons
) input-stream
&key
)
6347 (apply (first list
) input-stream
(rest list
)))
6350 (defmethod slurp-input-stream ((output-stream stream
) input-stream
6351 &key linewise prefix
(element-type 'character
) buffer-size
)
6352 (copy-stream-to-stream
6353 input-stream output-stream
6354 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6356 (defmethod slurp-input-stream ((x (eql 'string
)) stream
&key stripped
)
6357 (slurp-stream-string stream
:stripped stripped
))
6359 (defmethod slurp-input-stream ((x (eql :string
)) stream
&key stripped
)
6360 (slurp-stream-string stream
:stripped stripped
))
6362 (defmethod slurp-input-stream ((x (eql :lines
)) stream
&key count
)
6363 (slurp-stream-lines stream
:count count
))
6365 (defmethod slurp-input-stream ((x (eql :line
)) stream
&key
(at 0))
6366 (slurp-stream-line stream
:at at
))
6368 (defmethod slurp-input-stream ((x (eql :forms
)) stream
&key count
)
6369 (slurp-stream-forms stream
:count count
))
6371 (defmethod slurp-input-stream ((x (eql :form
)) stream
&key
(at 0))
6372 (slurp-stream-form stream
:at at
))
6374 (defmethod slurp-input-stream ((x (eql t
)) stream
&rest keys
&key
&allow-other-keys
)
6375 (apply 'slurp-input-stream
*standard-output
* stream keys
))
6377 (defmethod slurp-input-stream ((x null
) (stream t
) &key
)
6380 (defmethod slurp-input-stream ((pathname pathname
) input
6382 (element-type *default-stream-element-type
*)
6383 (external-format *utf-8-external-format
*)
6384 (if-exists :rename-and-delete
)
6385 (if-does-not-exist :create
)
6388 (with-output-file (output pathname
6389 :element-type element-type
6390 :external-format external-format
6391 :if-exists if-exists
6392 :if-does-not-exist if-does-not-exist
)
6393 (copy-stream-to-stream
6395 :element-type element-type
:buffer-size buffer-size
:linewise linewise
)))
6397 (defmethod slurp-input-stream (x stream
6398 &key linewise prefix
(element-type 'character
) buffer-size
)
6399 (declare (ignorable stream linewise prefix element-type buffer-size
))
6402 ((functionp x
) (funcall x stream
))
6404 ((output-stream-p x
)
6405 (copy-stream-to-stream
6407 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6409 (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x
)))))
6411 ;;;; Vomiting a stream, typically into the input of another program.
6412 (with-upgradability ()
6413 (defgeneric vomit-output-stream
(processor output-stream
&key
)
6415 "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
6416 PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
6417 some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
6419 Built-in methods include the following:
6420 * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
6421 * if PROCESSOR is a list, its first element should be a function.
6422 It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
6423 That is (x . y) will be treated as \(APPLY x <stream> y\)
6424 * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
6425 per copy-stream-to-stream, with appropriate keyword arguments.
6426 * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
6427 * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
6429 Programmers are encouraged to define their own methods for this generic function."))
6432 (defmethod vomit-output-stream ((function function
) output-stream
&key
)
6433 (funcall function output-stream
))
6435 (defmethod vomit-output-stream ((list cons
) output-stream
&key
)
6436 (apply (first list
) output-stream
(rest list
)))
6439 (defmethod vomit-output-stream ((input-stream stream
) output-stream
6440 &key linewise prefix
(element-type 'character
) buffer-size
)
6441 (copy-stream-to-stream
6442 input-stream output-stream
6443 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6445 (defmethod vomit-output-stream ((x string
) stream
&key fresh-line terpri
)
6447 (when fresh-line
(fresh-line stream
))
6448 (when terpri
(terpri stream
))
6451 (defmethod vomit-output-stream ((x (eql t
)) stream
&rest keys
&key
&allow-other-keys
)
6452 (apply 'vomit-output-stream
*standard-input
* stream keys
))
6454 (defmethod vomit-output-stream ((x null
) (stream t
) &key
)
6457 (defmethod vomit-output-stream ((pathname pathname
) input
6459 (element-type *default-stream-element-type
*)
6460 (external-format *utf-8-external-format
*)
6461 (if-exists :rename-and-delete
)
6462 (if-does-not-exist :create
)
6465 (with-output-file (output pathname
6466 :element-type element-type
6467 :external-format external-format
6468 :if-exists if-exists
6469 :if-does-not-exist if-does-not-exist
)
6470 (copy-stream-to-stream
6472 :element-type element-type
:buffer-size buffer-size
:linewise linewise
)))
6474 (defmethod vomit-output-stream (x stream
6475 &key linewise prefix
(element-type 'character
) buffer-size
)
6476 (declare (ignorable stream linewise prefix element-type buffer-size
))
6479 ((functionp x
) (funcall x stream
))
6482 (copy-stream-to-stream
6484 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
6486 (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x
)))))
6489 ;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
6490 (with-upgradability ()
6491 (define-condition subprocess-error
(error)
6492 ((code :initform nil
:initarg
:code
:reader subprocess-error-code
)
6493 (command :initform nil
:initarg
:command
:reader subprocess-error-command
)
6494 (process :initform nil
:initarg
:process
:reader subprocess-error-process
))
6495 (:report
(lambda (condition stream
)
6496 (format stream
"Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
6497 (subprocess-error-process condition
)
6498 (subprocess-error-command condition
)
6499 (subprocess-error-code condition
)))))
6501 (defun %check-result
(exit-code &key command process ignore-error-status
)
6502 (unless ignore-error-status
6503 (unless (eql exit-code
0)
6504 (cerror "IGNORE-ERROR-STATUS"
6505 'subprocess-error
:command command
:code exit-code
:process process
)))
6508 (defun %active-io-specifier-p
(specifier)
6509 "Determines whether a run-program I/O specifier requires Lisp-side processing
6510 via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
6511 or whether it's already taken care of by the implementation's underlying run-program."
6512 (not (typep specifier
'(or null string pathname
(member :interactive
:output
)
6513 #+(or cmucl
(and sbcl os-unix
) scl
) (or stream
(eql t
))
6514 #+lispworks file-stream
))))
6516 (defun %run-program
(command &rest keys
&key
&allow-other-keys
)
6517 "DEPRECATED. Use LAUNCH-PROGRAM instead."
6518 (apply 'launch-program command keys
))
6520 (defun %call-with-program-io
(gf tval stream-easy-p fun direction spec activep returner
6522 (element-type #-clozure
*default-stream-element-type
* #+clozure
'character
)
6523 (external-format *utf-8-external-format
*) &allow-other-keys
)
6524 ;; handle redirection for run-program and system
6525 ;; SPEC is the specification for the subprocess's input or output or error-output
6526 ;; TVAL is the value used if the spec is T
6527 ;; GF is the generic function to call to handle arbitrary values of SPEC
6528 ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
6529 ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
6530 ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
6531 ;; FUN is a function of the new reduced spec and an activity function to call with a stream
6532 ;; when the subprocess is active and communicating through that stream.
6533 ;; ACTIVEP is a boolean true if we will get to run code while the process is running
6534 ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
6535 ;; RETURNER is a function called with the value of the activity.
6536 ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
6537 (declare (ignorable stream-easy-p
))
6538 (let* ((actual-spec (if (eq spec t
) tval spec
))
6539 (activity-spec (if (eq actual-spec
:output
)
6542 (parameter-error "~S does not allow ~S as a ~S spec"
6543 'run-program
:output direction
))
6547 (labels ((activity (stream)
6548 (call-function returner
(call-stream-processor gf activity-spec stream
)))
6550 (funcall fun actual-spec nil
))
6553 (funcall fun
:stream
#'activity
)
6554 (with-temporary-file (:pathname tmp
)
6557 (with-output-file (s tmp
:if-exists
:overwrite
6558 :external-format external-format
6559 :element-type element-type
)
6561 (funcall fun tmp nil
))
6562 ((:output
:error-output
)
6563 (multiple-value-prog1 (funcall fun tmp nil
)
6564 (with-input-file (s tmp
6565 :external-format external-format
6566 :element-type element-type
)
6567 (activity s
)))))))))
6568 (typecase activity-spec
6569 ((or null string pathname
(eql :interactive
))
6571 #+(or cmucl
(and sbcl os-unix
) scl
) ;; streams are only easy on implementations that try very hard
6573 (if stream-easy-p
(easy-case) (hard-case)))
6577 (defmacro place-setter
(place)
6579 (let ((value (gensym)))
6580 `#'(lambda (,value
) (setf ,place
,value
)))))
6582 (defmacro with-program-input
(((reduced-input-var
6583 &optional
(input-activity-var (gensym) iavp
))
6584 input-form
&key setf stream-easy-p active keys
) &body body
)
6585 `(apply '%call-with-program-io
'vomit-output-stream
*standard-input
* ,stream-easy-p
6586 #'(lambda (,reduced-input-var
,input-activity-var
)
6587 ,@(unless iavp
`((declare (ignore ,input-activity-var
))))
6589 :input
,input-form
,active
(place-setter ,setf
) ,keys
))
6591 (defmacro with-program-output
(((reduced-output-var
6592 &optional
(output-activity-var (gensym) oavp
))
6593 output-form
&key setf stream-easy-p active keys
) &body body
)
6594 `(apply '%call-with-program-io
'slurp-input-stream
*standard-output
* ,stream-easy-p
6595 #'(lambda (,reduced-output-var
,output-activity-var
)
6596 ,@(unless oavp
`((declare (ignore ,output-activity-var
))))
6598 :output
,output-form
,active
(place-setter ,setf
) ,keys
))
6600 (defmacro with-program-error-output
(((reduced-error-output-var
6601 &optional
(error-output-activity-var (gensym) eoavp
))
6602 error-output-form
&key setf stream-easy-p active keys
)
6604 `(apply '%call-with-program-io
'slurp-input-stream
*error-output
* ,stream-easy-p
6605 #'(lambda (,reduced-error-output-var
,error-output-activity-var
)
6606 ,@(unless eoavp
`((declare (ignore ,error-output-activity-var
))))
6608 :error-output
,error-output-form
,active
(place-setter ,setf
) ,keys
))
6610 (defun %use-launch-program
(command &rest keys
6611 &key input output error-output ignore-error-status
&allow-other-keys
)
6612 ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
6613 #+(or cormanlisp gcl
(and lispworks os-windows
) mcl xcl
)
6615 command keys input output error-output ignore-error-status
;; ignore
6616 (not-implemented-error '%use-launch-program
))
6617 (when (member :stream
(list input output error-output
))
6618 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
6619 'run-program
:stream
))
6620 (let* ((active-input-p (%active-io-specifier-p input
))
6621 (active-output-p (%active-io-specifier-p output
))
6622 (active-error-output-p (%active-io-specifier-p error-output
))
6625 (active-output-p :output
)
6626 (active-input-p :input
)
6627 (active-error-output-p :error-output
)
6629 output-result error-output-result exit-code process-info
)
6630 (with-program-output ((reduced-output output-activity
)
6631 output
:keys keys
:setf output-result
6632 :stream-easy-p t
:active
(eq activity
:output
))
6633 (with-program-error-output ((reduced-error-output error-output-activity
)
6634 error-output
:keys keys
:setf error-output-result
6635 :stream-easy-p t
:active
(eq activity
:error-output
))
6636 (with-program-input ((reduced-input input-activity
)
6638 :stream-easy-p t
:active
(eq activity
:input
))
6640 (apply 'launch-program command
6641 :input reduced-input
:output reduced-output
6642 :error-output
(if (eq error-output
:output
) :output reduced-error-output
)
6644 (labels ((get-stream (stream-name &optional fallbackp
)
6645 (or (slot-value process-info stream-name
)
6647 (slot-value process-info
'bidir-stream
))))
6648 (run-activity (activity stream-name
&optional fallbackp
)
6649 (if-let (stream (get-stream stream-name fallbackp
))
6650 (funcall activity stream
)
6651 (error 'subprocess-error
6652 :code
`(:missing
,stream-name
)
6653 :command command
:process process-info
))))
6657 (:input
(run-activity input-activity
'input-stream t
))
6658 (:output
(run-activity output-activity
'output-stream t
))
6659 (:error-output
(run-activity error-output-activity
'error-output-stream
)))
6660 (close-streams process-info
)
6661 (setf exit-code
(wait-process process-info
)))))))
6662 (%check-result exit-code
6663 :command command
:process process-info
6664 :ignore-error-status ignore-error-status
)
6665 (values output-result error-output-result exit-code
)))
6667 (defun %normalize-system-command
(command) ;; helper for %USE-SYSTEM
6670 (list (escape-shell-command
6672 ((os-unix-p) (cons "exec" command
))
6675 (defun %redirected-system-command
(command in out err directory
) ;; helper for %USE-SYSTEM
6676 (flet ((redirect (spec operator
)
6679 (null (null-device-pathname))
6680 (string (parse-native-namestring spec
))
6683 (unless (equal operator
" 2>>")
6684 (parameter-error "~S: only the ~S argument can be ~S"
6685 'run-program
:error-output
:output
))
6686 (return-from redirect
'(" 2>&1"))))))
6689 (escape-shell-token (native-namestring pathname
)))))))
6690 (let* ((redirections (append (redirect in
" <") (redirect out
" >>") (redirect err
" 2>>")))
6691 (normalized (%normalize-system-command command
))
6692 (directory (or directory
#+(or abcl xcl
) (getcwd)))
6693 (chdir (when directory
6694 (let ((dir-arg (escape-shell-token (native-namestring directory
))))
6696 ((os-unix-p) `("cd " ,dir-arg
" ; "))
6697 ((os-windows-p) `("cd /d " ,dir-arg
" & ")))))))
6700 ((os-unix-p) `(,@(when redirections
`("exec " ,@redirections
" ; ")) ,@chdir
,normalized
))
6701 ((os-windows-p) `(,@redirections
" (" ,@chdir
,normalized
")")))))))
6703 (defun %system
(command &rest keys
&key directory
6704 input
(if-input-does-not-exist :error
)
6705 output
(if-output-exists :supersede
)
6706 error-output
(if-error-output-exists :supersede
)
6708 "A portable abstraction of a low-level call to libc's system()."
6709 (declare (ignorable keys directory input if-input-does-not-exist output
6710 if-output-exists error-output if-error-output-exists
))
6711 (when (member :stream
(list input output error-output
))
6712 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
6713 'run-program
:stream
))
6714 #+(or abcl allegro clozure cmucl ecl
(and lispworks os-unix
) mkcl sbcl scl
)
6715 (let (#+(or abcl ecl mkcl
)
6716 (version (parse-version
6718 (lisp-implementation-version)
6720 (second (split-string (implementation-identifier) :separator
'(#\-
))))))
6722 #+abcl
(unless (lexicographic< '< version
'(1 4 0)))
6723 #+ecl
(unless (lexicographic<= '< version
'(16 0 0)))
6724 #+mkcl
(unless (lexicographic<= '< version
'(1 1 9)))
6725 (return-from %system
6727 (apply 'launch-program
(%normalize-system-command command
) keys
)))))
6728 #+(or abcl clasp clisp cormanlisp ecl gcl genera
(and lispworks os-windows
) mkcl xcl
)
6729 (let ((%command
(%redirected-system-command command input output error-output directory
)))
6730 ;; see comments for these functions
6731 (%handle-if-does-not-exist input if-input-does-not-exist
)
6732 (%handle-if-exists output if-output-exists
)
6733 (%handle-if-exists error-output if-error-output-exists
)
6734 #+abcl
(ext:run-shell-command %command
)
6735 #+(or clasp ecl
) (let ((*standard-input
* *stdin
*)
6736 (*standard-output
* *stdout
*)
6737 (*error-output
* *stderr
*))
6738 (ext:system %command
))
6740 (let ((raw-exit-code
6742 #.
`(#+os-windows
,@'(ext:run-shell-command %command
)
6743 #+os-unix
,@'(ext:run-program
"/bin/sh" :arguments
`("-c" ,%command
))
6744 :wait t
:input
:terminal
:output
:terminal
)
6746 (if (minusp raw-exit-code
)
6747 (- 128 raw-exit-code
)
6749 #+cormanlisp
(win32:system %command
)
6750 #+gcl
(system:system %command
)
6751 #+genera
(not-implemented-error '%system
)
6752 #+(and lispworks os-windows
)
6753 (system:call-system %command
:current-directory directory
:wait t
)
6754 #+mcl
(ccl::with-cstrs
((%%command %command
)) (_system %%command
))
6755 #+mkcl
(mkcl:system %command
)
6756 #+xcl
(system:%run-shell-command %command
)))
6758 (defun %use-system
(command &rest keys
6759 &key input output error-output ignore-error-status
&allow-other-keys
)
6760 ;; helper for RUN-PROGRAM when using %system
6761 (let (output-result error-output-result exit-code
)
6762 (with-program-output ((reduced-output)
6763 output
:keys keys
:setf output-result
)
6764 (with-program-error-output ((reduced-error-output)
6765 error-output
:keys keys
:setf error-output-result
)
6766 (with-program-input ((reduced-input) input
:keys keys
)
6767 (setf exit-code
(apply '%system command
6768 :input reduced-input
:output reduced-output
6769 :error-output reduced-error-output keys
)))))
6770 (%check-result exit-code
6772 :ignore-error-status ignore-error-status
)
6773 (values output-result error-output-result exit-code
)))
6775 (defun run-program (command &rest keys
6776 &key ignore-error-status
(force-shell nil force-shell-suppliedp
)
6777 input
(if-input-does-not-exist :error
)
6778 output
(if-output-exists :supersede
)
6779 error-output
(if-error-output-exists :supersede
)
6780 (element-type #-clozure
*default-stream-element-type
* #+clozure
'character
)
6781 (external-format *utf-8-external-format
*)
6783 "Run program specified by COMMAND,
6784 either a list of strings specifying a program and list of arguments,
6785 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
6786 _synchronously_ process its output as specified and return the processing results
6787 when the program and its output processing are complete.
6789 Always call a shell (rather than directly execute the command when possible)
6790 if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
6791 specified to be NIL.
6793 Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
6794 unless IGNORE-ERROR-STATUS is specified.
6796 If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
6797 designating the null device, the file at that path is used as output.
6798 If it's :INTERACTIVE, output is inherited from the current process;
6799 beware that this may be different from your *STANDARD-OUTPUT*,
6800 and under SLIME will be on your *inferior-lisp* buffer.
6801 If it's T, output goes to your current *STANDARD-OUTPUT* stream.
6802 Otherwise, OUTPUT should be a value that is a suitable first argument to
6803 SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
6804 In this case, RUN-PROGRAM will create a temporary stream for the program output;
6805 the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
6806 using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
6807 The primary value resulting from that call (or NIL if no call was needed)
6808 will be the first value returned by RUN-PROGRAM.
6809 E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
6810 And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
6811 stripped of any ending newline.
6813 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
6814 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
6815 default). The meaning of these values and their effect on the case
6816 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
6817 to OPEN with :DIRECTION :OUTPUT.
6819 ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
6820 as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
6821 Also :OUTPUT means redirecting the error output to the output stream,
6822 in which case NIL is returned.
6824 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
6825 affects ERROR-OUTPUT rather than OUTPUT.
6827 INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
6828 no value is returned, and T designates the *STANDARD-INPUT*.
6830 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
6831 or a pathname, can take the values :CREATE and :ERROR (the
6832 default). The meaning of these values is analogous to the
6833 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
6835 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
6836 to your Lisp implementation, when applicable, for creation of the output stream.
6838 One and only one of the stream slurping or vomiting may or may not happen
6839 in parallel in parallel with the subprocess,
6840 depending on options and implementation,
6841 and with priority being given to output processing.
6842 Other streams are completely produced or consumed
6843 before or after the subprocess is spawned, using temporary files.
6845 RUN-PROGRAM returns 3 values:
6846 0- the result of the OUTPUT slurping if any, or NIL
6847 1- the result of the ERROR-OUTPUT slurping if any, or NIL
6848 2- either 0 if the subprocess exited with success status,
6849 or an indication of failure via the EXIT-CODE of the process"
6850 (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
6851 if-error-output-exists element-type external-format ignore-error-status
))
6852 #-
(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl
)
6853 (not-implemented-error 'run-program
)
6854 (apply (if (or force-shell
6855 ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
6856 ;; But don't override user's specified preference. [2015/06/29:rpg]
6857 (and (stringp command
)
6858 (or (not force-shell-suppliedp
)
6859 #-
(or allegro clisp clozure sbcl
) (os-cond ((os-windows-p) t
))))
6860 #+(or clasp clisp cormanlisp gcl
(and lispworks os-windows
) mcl xcl
) t
6861 ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
6862 #+ecl
#.
(if-let (ver (parse-version (lisp-implementation-version)))
6863 (lexicographic<= '< ver
'(16 0 0)))
6864 #+(and lispworks os-unix
) (%interactivep input output error-output
))
6865 '%use-system
'%use-launch-program
)
6868 ;;;; ---------------------------------------------------------------------------
6869 ;;;; Generic support for configuration files
6871 (uiop/package
:define-package
:uiop
/configuration
6872 (:recycle
:uiop
/configuration
:asdf
/configuration
) ;; necessary to upgrade from 2.27.
6873 (:use
:uiop
/common-lisp
:uiop
/utility
6874 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
:uiop
/lisp-build
)
6876 #:user-configuration-directories
#:system-configuration-directories
;; implemented in backward-driver
6877 #:in-first-directory
#:in-user-configuration-directory
#:in-system-configuration-directory
;; idem
6879 #:xdg-data-home
#:xdg-config-home
#:xdg-data-dirs
#:xdg-config-dirs
6880 #:xdg-cache-home
#:xdg-runtime-dir
#:system-config-pathnames
6881 #:filter-pathname-set
#:xdg-data-pathnames
#:xdg-config-pathnames
6882 #:find-preferred-file
#:xdg-data-pathname
#:xdg-config-pathname
6883 #:validate-configuration-form
#:validate-configuration-file
#:validate-configuration-directory
6884 #:configuration-inheritance-directive-p
6885 #:report-invalid-form
#:invalid-configuration
#:*ignored-configuration-form
* #:*user-cache
*
6886 #:*clear-configuration-hook
* #:clear-configuration
#:register-clear-configuration-hook
6887 #:resolve-location
#:location-designator-p
#:location-function-p
#:*here-directory
*
6888 #:resolve-relative-location
#:resolve-absolute-location
#:upgrade-configuration
))
6889 (in-package :uiop
/configuration
)
6891 (with-upgradability ()
6892 (define-condition invalid-configuration
()
6893 ((form :reader condition-form
:initarg
:form
)
6894 (location :reader condition-location
:initarg
:location
)
6895 (format :reader condition-format
:initarg
:format
)
6896 (arguments :reader condition-arguments
:initarg
:arguments
:initform nil
))
6897 (:report
(lambda (c s
)
6898 (format s
(compatfmt "~@<~? (will be skipped)~@:>")
6899 (condition-format c
)
6900 (list* (condition-form c
) (condition-location c
)
6901 (condition-arguments c
))))))
6903 (defun configuration-inheritance-directive-p (x)
6904 "Is X a configuration inheritance directive?"
6905 (let ((kw '(:inherit-configuration
:ignore-inherited-configuration
)))
6907 (and (length=n-p x
1) (member (car x
) kw
)))))
6909 (defun report-invalid-form (reporter &rest args
)
6910 "Report an invalid form according to REPORTER and various ARGS"
6913 (apply 'error
'invalid-configuration args
))
6915 (apply reporter args
))
6917 (apply 'error reporter args
))
6919 (apply 'apply
(append reporter args
)))))
6921 (defvar *ignored-configuration-form
* nil
6922 "Have configuration forms been ignored while parsing the configuration?")
6924 (defun validate-configuration-form (form tag directive-validator
6925 &key location invalid-form-reporter
)
6926 "Validate a configuration FORM. By default it will raise an error if the
6927 FORM is not valid. Otherwise it will return the validated form.
6928 Arguments control the behavior:
6929 The configuration FORM should be of the form (TAG . <rest>)
6930 Each element of <rest> will be checked by first seeing if it's a configuration inheritance
6931 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
6933 In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
6934 reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
6935 the configuration form appeared."
6936 (unless (and (consp form
) (eq (car form
) tag
))
6937 (setf *ignored-configuration-form
* t
)
6938 (report-invalid-form invalid-form-reporter
:form form
:location location
)
6939 (return-from validate-configuration-form nil
))
6940 (loop :with inherit
= 0 :with ignore-invalid-p
= nil
:with x
= (list tag
)
6941 :for directive
:in
(cdr form
)
6943 ((configuration-inheritance-directive-p directive
)
6945 ((eq directive
:ignore-invalid-entries
)
6946 (setf ignore-invalid-p t
) t
)
6947 ((funcall directive-validator directive
)
6952 (setf *ignored-configuration-form
* t
)
6953 (report-invalid-form invalid-form-reporter
:form directive
:location location
)
6955 :do
(push directive x
)
6957 (unless (= inherit
1)
6958 (report-invalid-form invalid-form-reporter
6959 :form form
:location location
6960 ;; we throw away the form and location arguments, hence the ~2*
6961 ;; this is necessary because of the report in INVALID-CONFIGURATION
6962 :format
(compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
6963 One and only one of ~S or ~S is required.~@:>")
6964 :arguments
'(:inherit-configuration
:ignore-inherited-configuration
)))
6965 (return (nreverse x
))))
6967 (defun validate-configuration-file (file validator
&key description
)
6968 "Validate a configuration FILE. The configuration file should have only one s-expression
6969 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
6971 (let ((forms (read-file-forms file
)))
6972 (unless (length=n-p forms
1)
6973 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
6975 (funcall validator
(car forms
) :location file
)))
6977 (defun validate-configuration-directory (directory tag validator
&key invalid-form-reporter
)
6978 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
6979 be applied to the results to yield a configuration form. Current
6980 values of TAG include :source-registry and :output-translations."
6981 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
6984 (directory* (make-pathname :name
*wild
* :type
"conf" :defaults directory
))))
6985 #'string
< :key
#'namestring
)))
6987 ,@(loop :for file
:in files
:append
6988 (loop :with ignore-invalid-p
= nil
6989 :for form
:in
(read-file-forms file
)
6990 :when
(eq form
:ignore-invalid-entries
)
6991 :do
(setf ignore-invalid-p t
)
6993 :when
(funcall validator form
)
6996 :when ignore-invalid-p
6997 :do
(setf *ignored-configuration-form
* t
)
6999 :do
(report-invalid-form invalid-form-reporter
:form form
:location file
)))
7000 :inherit-configuration
)))
7002 (defun resolve-relative-location (x &key ensure-directory wilden
)
7003 "Given a designator X for an relative location, resolve it to a pathname."
7008 (string (parse-unix-namestring
7009 x
:ensure-directory ensure-directory
))
7012 (resolve-relative-location
7013 (car x
) :ensure-directory ensure-directory
:wilden wilden
)
7014 (let* ((car (resolve-relative-location
7015 (car x
) :ensure-directory t
:wilden nil
)))
7017 (resolve-relative-location
7018 (cdr x
) :ensure-directory ensure-directory
:wilden wilden
)
7020 ((eql :*/) *wild-directory
*)
7021 ((eql :**/) *wild-inferiors
*)
7022 ((eql :*.
*.
*) *wild-file
*)
7023 ((eql :implementation
)
7024 (parse-unix-namestring
7025 (implementation-identifier) :ensure-directory t
))
7026 ((eql :implementation-type
)
7027 (parse-unix-namestring
7028 (string-downcase (implementation-type)) :ensure-directory t
))
7030 (parse-unix-namestring (hostname) :ensure-directory t
)))
7031 :wilden
(and wilden
(not (pathnamep x
)) (not (member x
'(:*/ :**/ :*.
*.
*))))
7034 (defvar *here-directory
* nil
7035 "This special variable is bound to the currect directory during calls to
7036 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
7039 (defvar *user-cache
* nil
7040 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
7042 (defun resolve-absolute-location (x &key ensure-directory wilden
)
7043 "Given a designator X for an absolute location, resolve it to a pathname"
7049 (let ((p #-mcl
(parse-namestring x
)
7050 #+mcl
(probe-posix x
)))
7051 #+mcl
(unless p
(error "POSIX pathname ~S does not exist" x
))
7052 (if ensure-directory
(ensure-directory-pathname p
) p
)))
7054 (return-from resolve-absolute-location
7056 (resolve-absolute-location
7057 (car x
) :ensure-directory ensure-directory
:wilden wilden
)
7059 (resolve-relative-location
7060 (cdr x
) :ensure-directory ensure-directory
:wilden wilden
)
7061 (resolve-absolute-location
7062 (car x
) :ensure-directory t
:wilden nil
)))))
7064 ;; special magic! we return a relative pathname,
7065 ;; but what it means to the output-translations is
7066 ;; "relative to the root of the source pathname's host and device".
7067 (return-from resolve-absolute-location
7068 (let ((p (make-pathname :directory
'(:relative
))))
7069 (if wilden
(wilden p
) p
))))
7070 ((eql :home
) (user-homedir-pathname))
7071 ((eql :here
) (resolve-absolute-location
7072 (or *here-directory
* (pathname-directory-pathname (load-pathname)))
7073 :ensure-directory t
:wilden nil
))
7074 ((eql :user-cache
) (resolve-absolute-location
7075 *user-cache
* :ensure-directory t
:wilden nil
)))
7076 :wilden
(and wilden
(not (pathnamep x
)))
7077 :resolve-symlinks
*resolve-symlinks
*
7080 ;; Try to override declaration in previous versions of ASDF.
7081 (declaim (ftype (function (t &key
(:directory boolean
) (:wilden boolean
)
7082 (:ensure-directory boolean
)) t
) resolve-location
))
7084 (defun* (resolve-location) (x &key ensure-directory wilden directory
)
7085 "Resolve location designator X into a PATHNAME"
7086 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
7087 (loop* :with dirp
= (or directory ensure-directory
)
7088 :with
(first . rest
) = (if (atom x
) (list x
) x
)
7089 :with path
= (or (resolve-absolute-location
7090 first
:ensure-directory
(and (or dirp rest
) t
)
7091 :wilden
(and wilden
(null rest
)))
7093 :for
(element . morep
) :on rest
7094 :for dir
= (and (or morep dirp
) t
)
7095 :for wild
= (and wilden
(not morep
))
7096 :for sub
= (merge-pathnames*
7097 (resolve-relative-location
7098 element
:ensure-directory dir
:wilden wild
)
7100 :do
(setf path
(if (absolute-pathname-p sub
) (resolve-symlinks* sub
) sub
))
7101 :finally
(return path
)))
7103 (defun location-designator-p (x)
7104 "Is X a designator for a location?"
7105 ;; NIL means "skip this entry", or as an output translation, same as translation input.
7106 ;; T means "any input" for a translation, or as output, same as translation input.
7107 (flet ((absolute-component-p (c)
7108 (typep c
'(or string pathname
7109 (member :root
:home
:here
:user-cache
))))
7110 (relative-component-p (c)
7111 (typep c
'(or string pathname
7112 (member :*/ :**/ :*.
*.
* :implementation
:implementation-type
)))))
7113 (or (typep x
'boolean
)
7114 (absolute-component-p x
)
7115 (and (consp x
) (absolute-component-p (first x
)) (every #'relative-component-p
(rest x
))))))
7117 (defun location-function-p (x)
7118 "Is X the specification of a location function?"
7119 ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
7120 (and (length=n-p x
2) (eq (car x
) :function
)))
7122 (defvar *clear-configuration-hook
* '())
7124 (defun register-clear-configuration-hook (hook-function &optional call-now-p
)
7125 "Register a function to be called when clearing configuration"
7126 (register-hook-function '*clear-configuration-hook
* hook-function call-now-p
))
7128 (defun clear-configuration ()
7129 "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
7130 (call-functions *clear-configuration-hook
*))
7132 (register-image-dump-hook 'clear-configuration
)
7134 (defun upgrade-configuration ()
7135 "If a previous version of ASDF failed to read some configuration, try again now."
7136 (when *ignored-configuration-form
*
7137 (clear-configuration)
7138 (setf *ignored-configuration-form
* nil
)))
7141 (defun get-folder-path (folder)
7142 "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
7143 this function tries to locate the Windows FOLDER for one of
7144 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
7145 Returns NIL when the folder is not defined (e.g., not on Windows)."
7146 (or #+(and lispworks os-windows
) (sys:get-folder-path folder
)
7147 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
7149 (:local-appdata
(or (getenv-absolute-directory "LOCALAPPDATA")
7150 (subpathname* (get-folder-path :appdata
) "Local")))
7151 (:appdata
(getenv-absolute-directory "APPDATA"))
7152 (:common-appdata
(or (getenv-absolute-directory "ALLUSERSAPPDATA")
7153 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
7156 ;; Support for the XDG Base Directory Specification
7157 (defun xdg-data-home (&rest more
)
7158 "Returns an absolute pathname for the directory containing user-specific data files.
7159 MORE may contain specifications for a subpath relative to this directory: a
7160 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7161 also \"Configuration DSL\"\) in the ASDF manual."
7162 (resolve-absolute-location
7163 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
7165 ((os-windows-p) (get-folder-path :local-appdata
))
7166 (t (subpathname (user-homedir-pathname) ".local/share/"))))
7169 (defun xdg-config-home (&rest more
)
7170 "Returns a pathname for the directory containing user-specific configuration files.
7171 MORE may contain specifications for a subpath relative to this directory: a
7172 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7173 also \"Configuration DSL\"\) in the ASDF manual."
7174 (resolve-absolute-location
7175 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
7177 ((os-windows-p) (xdg-data-home "config/"))
7178 (t (subpathname (user-homedir-pathname) ".config/"))))
7181 (defun xdg-data-dirs (&rest more
)
7182 "The preference-ordered set of additional paths to search for data files.
7183 Returns a list of absolute directory pathnames.
7184 MORE may contain specifications for a subpath relative to these directories: a
7185 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7186 also \"Configuration DSL\"\) in the ASDF manual."
7187 (mapcar #'(lambda (d) (resolve-location `(,d
,more
)))
7188 (or (remove nil
(getenv-absolute-directories "XDG_DATA_DIRS"))
7190 ((os-windows-p) (mapcar 'get-folder-path
'(:appdata
:common-appdata
)))
7191 (t (mapcar 'parse-unix-namestring
'("/usr/local/share/" "/usr/share/")))))))
7193 (defun xdg-config-dirs (&rest more
)
7194 "The preference-ordered set of additional base paths to search for configuration files.
7195 Returns a list of absolute directory pathnames.
7196 MORE may contain specifications for a subpath relative to these directories:
7197 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7198 also \"Configuration DSL\"\) in the ASDF manual."
7199 (mapcar #'(lambda (d) (resolve-location `(,d
,more
)))
7200 (or (remove nil
(getenv-absolute-directories "XDG_CONFIG_DIRS"))
7202 ((os-windows-p) (xdg-data-dirs "config/"))
7203 (t (mapcar 'parse-unix-namestring
'("/etc/xdg/")))))))
7205 (defun xdg-cache-home (&rest more
)
7206 "The base directory relative to which user specific non-essential data files should be stored.
7207 Returns an absolute directory pathname.
7208 MORE may contain specifications for a subpath relative to this directory: a
7209 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7210 also \"Configuration DSL\"\) in the ASDF manual."
7211 (resolve-absolute-location
7212 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
7214 ((os-windows-p) (xdg-data-home "cache/"))
7215 (t (subpathname* (user-homedir-pathname) ".cache/"))))
7218 (defun xdg-runtime-dir (&rest more
)
7219 "Pathname for user-specific non-essential runtime files and other file objects,
7220 such as sockets, named pipes, etc.
7221 Returns an absolute directory pathname.
7222 MORE may contain specifications for a subpath relative to this directory: a
7223 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7224 also \"Configuration DSL\"\) in the ASDF manual."
7225 ;; The XDG spec says that if not provided by the login system, the application should
7226 ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
7227 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more
)))
7229 ;;; NOTE: modified the docstring because "system user configuration
7230 ;;; directories" seems self-contradictory. I'm not sure my wording is right.
7231 (defun system-config-pathnames (&rest more
)
7232 "Return a list of directories where are stored the system's default user configuration information.
7233 MORE may contain specifications for a subpath relative to these directories: a
7234 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7235 also \"Configuration DSL\"\) in the ASDF manual."
7236 (declare (ignorable more
))
7238 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more
))))))
7240 (defun filter-pathname-set (dirs)
7241 "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
7242 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs
) :from-end t
:test
'equal
))
7244 (defun xdg-data-pathnames (&rest more
)
7245 "Return a list of absolute pathnames for application data directories. With APP,
7246 returns directory for data for that application, without APP, returns the set of directories
7247 for storing all application configurations.
7248 MORE may contain specifications for a subpath relative to these directories: a
7249 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7250 also \"Configuration DSL\"\) in the ASDF manual."
7251 (filter-pathname-set
7252 `(,(xdg-data-home more
)
7253 ,@(xdg-data-dirs more
))))
7255 (defun xdg-config-pathnames (&rest more
)
7256 "Return a list of pathnames for application configuration.
7257 MORE may contain specifications for a subpath relative to these directories: a
7258 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7259 also \"Configuration DSL\"\) in the ASDF manual."
7260 (filter-pathname-set
7261 `(,(xdg-config-home more
)
7262 ,@(xdg-config-dirs more
))))
7264 (defun find-preferred-file (files &key
(direction :input
))
7265 "Find first file in the list of FILES that exists (for direction :input or :probe)
7266 or just the first one (for direction :output or :io).
7267 Note that when we say \"file\" here, the files in question may be directories."
7268 (find-if (ecase direction
((:probe
:input
) 'probe-file
*) ((:output
:io
) 'identity
)) files
))
7270 (defun xdg-data-pathname (&optional more
(direction :input
))
7271 (find-preferred-file (xdg-data-pathnames more
) :direction direction
))
7273 (defun xdg-config-pathname (&optional more
(direction :input
))
7274 (find-preferred-file (xdg-config-pathnames more
) :direction direction
))
7276 (defun compute-user-cache ()
7277 "Compute (and return) the location of the default user-cache for translate-output
7278 objects. Side-effects for cached file location computation."
7279 (setf *user-cache
* (xdg-cache-home "common-lisp" :implementation
)))
7280 (register-image-restore-hook 'compute-user-cache
))
7281 ;;; -------------------------------------------------------------------------
7282 ;;; Hacks for backward-compatibility with older versions of UIOP
7284 (uiop/package
:define-package
:uiop
/backward-driver
7285 (:recycle
:uiop
/backward-driver
:asdf
/backward-driver
:uiop
)
7286 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/version
7287 :uiop
/pathname
:uiop
/stream
:uiop
/os
:uiop
/image
7288 :uiop
/run-program
:uiop
/lisp-build
:uiop
/configuration
)
7291 #:user-configuration-directories
#:system-configuration-directories
7292 #:in-first-directory
#:in-user-configuration-directory
#:in-system-configuration-directory
7293 #:version-compatible-p
))
7294 (in-package :uiop
/backward-driver
)
7296 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
7297 (with-deprecation ((version-deprecation *uiop-version
* :style-warning
"3.2" :warning
"3.4"))
7298 ;; Backward compatibility with ASDF 2.000 to 2.26
7300 ;; For backward-compatibility only, for people using internals
7301 ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
7302 ;; Will be removed after 2015-12.
7303 (defun coerce-pathname (name &key type defaults
)
7304 "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead."
7305 (parse-unix-namestring name
:type type
:defaults defaults
))
7307 ;; Backward compatibility for ASDF 2.27 to 3.1.4
7308 (defun user-configuration-directories ()
7309 "Return the current user's list of user configuration directories
7310 for configuring common-lisp.
7311 DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
7312 (xdg-config-pathnames "common-lisp"))
7313 (defun system-configuration-directories ()
7314 "Return the list of system configuration directories for common-lisp.
7315 DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead."
7316 (system-config-pathnames "common-lisp"))
7317 (defun in-first-directory (dirs x
&key
(direction :input
))
7318 "Finds the first appropriate file named X in the list of DIRS for I/O
7319 in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
7320 If direction is :INPUT or :PROBE, will return the first extant file named
7321 X in one of the DIRS.
7322 If direction is :OUTPUT or :IO, will simply return the file named X in the
7323 first element of DIRS that exists. DEPRECATED."
7324 (find-preferred-file
7325 (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir
) x
)) dirs
)
7326 :direction direction
))
7327 (defun in-user-configuration-directory (x &key
(direction :input
))
7328 "Return the file named X in the user configuration directory for common-lisp.
7330 (xdg-config-pathname `("common-lisp" ,x
) direction
))
7331 (defun in-system-configuration-directory (x &key
(direction :input
))
7332 "Return the pathname for the file named X under the system configuration directory
7333 for common-lisp. DEPRECATED."
7334 (find-preferred-file (system-config-pathnames "common-lisp" x
) :direction direction
))
7337 ;; Backward compatibility with ASDF 1 to ASDF 2.32
7339 (defun version-compatible-p (provided-version required-version
)
7340 "Is the provided version a compatible substitution for the required-version?
7341 If major versions differ, it's not compatible.
7342 If they are equal, then any later version is compatible,
7343 with later being determined by a lexicographical comparison of minor numbers.
7345 (let ((x (parse-version provided-version nil
))
7346 (y (parse-version required-version nil
)))
7347 (and x y
(= (car x
) (car y
)) (lexicographic<= '< (cdr y
) (cdr x
)))))))
7349 ;;;; ---------------------------------------------------------------------------
7350 ;;;; Re-export all the functionality in UIOP
7352 (uiop/package
:define-package
:uiop
/driver
7353 (:nicknames
:uiop
:asdf
/driver
) ;; asdf/driver is obsolete (uiop isn't);
7354 ;; but asdf/driver is still used by swap-bytes, static-vectors.
7355 (:use
:uiop
/common-lisp
)
7356 ;; NB: not reexporting uiop/common-lisp
7357 ;; which include all of CL with compatibility modifications on select platforms,
7358 ;; that could cause potential conflicts for packages that would :use (cl uiop)
7359 ;; or :use (closer-common-lisp uiop), etc.
7361 :uiop
/package
:uiop
/utility
:uiop
/version
7362 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
7363 :uiop
/launch-program
:uiop
/run-program
7364 :uiop
/lisp-build
:uiop
/configuration
:uiop
/backward-driver
))
7366 ;; Provide both lowercase and uppercase, to satisfy more people.
7367 (provide "uiop") (provide "UIOP")
