Newer
Older
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces
Francois-Rene Rideau
committed
(asdf/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
(:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os
:asdf/component :asdf/system :asdf/operation :asdf/action
:asdf/lisp-build :asdf/operate :asdf/output-translations)
(:export
#:*asdf-verbose*
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
#:merge-component-name-type
#:operation-forced
#:operation-on-failure
#:operation-on-warnings
#:run-shell-command
#:system-definition-pathname))
(in-package :asdf/backward-interface)
(defvar *asdf-verbose* nil) ; worked around by cl-protobufs. It was a mistake to introduce it. mea culpa -fare
(defun* component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defun* merge-component-name-type (name &key type defaults)
;; For backward-compatibility only, for people using internals.
;; Will be removed in a future release, e.g. 2.016.
(warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
(coerce-pathname name :type type :defaults defaults))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric* operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation))
#-gcl<2.7 (defgeneric* (setf operation-on-warnings) (x operation))
#-gcl<2.7 (defgeneric* (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
(declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
(declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
(declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
(defun* system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete,
;; but that won't happen until all clients have been updated.
;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
"Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
It used to expose ASDF internals with subtle differences with respect to
user expectations, that have been refactored away since.
We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;)
(system-source-file x))
;;;; ASDF-Binary-Locations compatibility
(defun* enable-asdf-binary-locations-compatibility
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
(subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(include-per-user-information nil)
(map-all-source-files (or #+(or clisp ecl mkcl) t nil))
(source-to-target-mappings nil))
#+(or clisp ecl mkcl)
(when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((fasl-type (fasl-type))
(mapped-files (if map-all-source-files *wild-file*
(make-pathname :type fasl-type :defaults *wild-file*)))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
:implementation ,*wild-inferiors*)
`(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
`(:output-translations
,@source-to-target-mappings
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
#+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
((:root ,*wild-inferiors* ,mapped-files)
(,@destination-directory ,mapped-files))
(t t)
:ignore-inherited-configuration))))
(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
(declare (ignorable operation-class system args))
(when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
(error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
In case you insist on preserving your previous A-B-L configuration, but
do not know how to achieve the same effect with A-O-T, you may use function
ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
call that function where you would otherwise have loaded and configured A-B-L.")))
;;;; run-shell-command
;;
;; run-shell-command functions for other lisp implementations will be
;; gratefully accepted, if they do the same thing.
;; If the docstring is ambiguous, send a bug report.
;;
;; WARNING! The function below is mostly dysfunctional.
;; For instance, it will probably run fine on most implementations on Unix,
;; which will hopefully use the shell /bin/sh (which we force in some cases)
;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
;; But behavior on Windows may vary wildly between implementations,
;; either relying on your having installed a POSIX sh, or going through
;; the CMD.EXE interpreter, for a totally different meaning, depending on
;; what is easily expressible in said implementation.
;;
;; We probably should move this functionality to its own system and deprecate
;; use of it from the asdf package. However, this would break unspecified
;; existing software, so until a clear alternative exists, we can't deprecate
;; it, and even after it's been deprecated, we will support it for a few
;; years so everyone has time to migrate away from it. -- fare 2009-12-01
;;
;; As a suggested replacement which is portable to all ASDF-supported
;; implementations and operating systems except Genera, I recommend
;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
(defun* run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
#+abcl
(ext:run-shell-command command :output *verbose-out*)
#+allegro
;; will this fail if command has embedded quotes - it seems to work
(multiple-value-bind (stdout stderr exit-code)
(excl.osi:command-output
#-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
#+mswindows command ; BEWARE!
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
(asdf-message "~{~&~a~%~}~%" stderr)
(asdf-message "~{~&~a~%~}~%" stdout)
exit-code)
#+clisp
;; CLISP returns NIL for exit status zero.
(if *verbose-out*
(let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
command))
(outstream (ext:run-shell-command new-command :output :stream :wait t)))
(multiple-value-bind (retval out-lines)
(unwind-protect
(parse-clisp-shell-output outstream)
(ignore-errors (close outstream)))
(asdf-message "~{~&~a~%~}~%" out-lines)
retval))
;; there will be no output, just grab up the exit status
(or (ext:run-shell-command command :output nil :wait t) 0))
#+clozure
(nth-value 1
(ccl:external-process-status
(ccl:run-program
(cond
((os-unix-p) "/bin/sh")
((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
(t (error "Unsupported OS")))
(if (os-unix-p) (list "-c" command) '())
:input nil :output *verbose-out* :wait t)))
#+(or cmu scl)
(ext:process-exit-code
(ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*))
#+cormanlisp
(win32:system command)
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(ext:system command)
#+gcl
(lisp:system command)
#+lispworks
(apply 'system:call-system-showing-output command
:show-cmd nil :prefix "" :output-stream *verbose-out*
(when (os-unix-p) '(:shell-type "/bin/sh")))
#+mcl
(ccl::with-cstrs ((%command command)) (_system %command))
#+mkcl
;; This has next to no chance of working on basic Windows!
;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
(multiple-value-bind (io process exit-code)
(apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
(list "-c" command)
:input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
#-windows '(:search nil))
(declare (ignore io process))
exit-code)
#+sbcl
(sb-ext:process-exit-code
(apply 'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*
#+win32 '(:search t) #-win32 nil))
#+xcl
(ext:run-shell-command command)
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")))
#+clisp
(defun* parse-clisp-shell-output (stream)
"Helper function for running shell commands under clisp. Parses a specially-
crafted output string to recover the exit status of the shell command and a
list of lines of output."
(loop :with status-prefix = "ASDF-EXIT-STATUS "
:with prefix-length = (length status-prefix)
:with exit-status = -1 :with lines = ()
:for line = (read-line stream nil nil)
:while line :do (push line lines) :finally
(let* ((last (car lines))
(status (and last (>= (length last) prefix-length)
(string-equal last status-prefix :end1 prefix-length)
(parse-integer last :start prefix-length :junk-allowed t))))
(when status
(setf exit-status status)
(pop lines) (when (equal "" (car lines)) (pop lines)))
(return (values exit-status (reverse lines))))))