source: branches/0.23.x/abcl/contrib/asdf-install/port.lisp @ 13037

Last change on this file since 13037 was 13037, checked in by Mark Evenson, 12 years ago

[backport r13030,r13031] Ensure ASDF registry contains ASDF-INSTALL locations.

Fix compiler warning about *gpg-program* being assumed special.

File size: 17.9 KB
Line 
1(in-package #:asdf-install)
2
3;;; 'port.lisp' is loaded before 'variables.lisp' primarily for the
4;;; definiton of GET-ENV-VAR, but still needs the following specials
5;;; which would otherwise be in 'variables.lisp'.
6(defparameter *shell-path* "/bin/sh"
7  "The path to a Bourne compatible command shell in physical pathname notation.")
8
9(defvar *gpg-command* "gpg"
10  "Location of the gpg binary, if for some reason, it does not appear
11  in the default path for /bin/sh.")
12;;; End variables
13
14(defvar *temporary-files*)
15
16(eval-when (:load-toplevel :compile-toplevel :execute)
17  #+:allegro
18  (require :osi)
19  #+:allegro
20  (require :socket)
21  #+:digitool
22  (require :opentransport)
23  #+:ecl
24  (require :sockets)
25  #+:lispworks
26  (require "comm")
27  )
28
29(defun get-env-var (name)
30  #+:allegro (sys:getenv name)
31  #+:clisp (ext:getenv name)
32  #+:cmu (cdr (assoc (intern (substitute #\_ #\- name)
33                             :keyword)
34                     ext:*environment-list*))
35  #+:ecl (ext:getenv name)
36  #+:lispworks (lw:environment-variable name)
37  #+(or :mcl :openmcl) (ccl::getenv name)
38  #+:sbcl (sb-ext:posix-getenv name)
39  #+:scl (cdr (assoc name ext:*environment-list* :test #'string=))
40  #+abcl (ext:getenv name)
41  )
42
43#-:digitool
44(defun system-namestring (pathname)
45  (namestring (truename pathname)))
46
47#+:digitool
48(defvar *start-up-volume*
49  (second (pathname-directory (truename "ccl:"))))
50
51#+:digitool
52(defun system-namestring (pathname)
53  ;; this tries to adjust the root directory to eliminate the spurious
54  ;; volume name for the boot file system; it also avoids use of
55  ;; TRUENAME as some applications are for not yet existent files
56  (let ((truename (probe-file pathname)))
57    (unless truename
58      (setf truename
59            (translate-logical-pathname
60             (merge-pathnames pathname *default-pathname-defaults*))))
61    (let ((directory (pathname-directory truename)))
62      (flet ((string-or-nil (value) (when (stringp value) value))
63             (absolute-p (directory) (eq (first directory) :absolute))
64             (root-volume-p (directory)
65               (equal *start-up-volume* (second directory))))
66        (format nil "~:[~;/~]~{~a/~}~@[~a~]~@[.~a~]"
67                (absolute-p directory)
68                (if (root-volume-p directory) (cddr directory) (cdr directory))
69                (string-or-nil (pathname-name truename))
70                (string-or-nil (pathname-type truename)))))))
71
72#+:digitool
73(progn
74  (defun |read-linefeed-eol-comment|
75         (stream char &optional (eol '(#\return #\linefeed)))
76    (loop (setf char (read-char stream nil nil))
77          (unless char (return))
78          (when (find char eol) (return)))
79    (values))
80 
81  (set-syntax-from-char #\linefeed #\space)
82  (set-macro-character #\; #'|read-linefeed-eol-comment| nil *readtable*))
83
84;; for non-SBCL we just steal this from SB-EXECUTABLE
85#-(or :digitool)
86(defvar *stream-buffer-size* 8192)
87#-(or :digitool)
88(defun copy-stream (from to)
89  "Copy into TO from FROM until end of the input stream, in blocks of
90*stream-buffer-size*.  The streams should have the same element type."
91  (unless (subtypep (stream-element-type to) (stream-element-type from))
92    (error "Incompatible streams ~A and ~A." from to))
93  (let ((buf (make-array *stream-buffer-size*
94       :element-type (stream-element-type from))))
95    (loop
96      (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
97                 #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
98                 #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
99        (when (zerop pos) (return))
100        (write-sequence buf to :end pos)))))
101
102#+:digitool
103(defun copy-stream (from to)
104  "Perform copy and map EOL mode."
105  (multiple-value-bind (reader reader-arg) (ccl::stream-reader from)
106    (multiple-value-bind (writer writer-arg) (ccl::stream-writer to)
107      (let ((datum nil))
108        (loop (unless (setf datum (funcall reader reader-arg))
109                (return))
110              (funcall writer writer-arg datum))))))
111
112(defun make-stream-from-url (url)
113  #+(or :sbcl :ecl)
114  (let ((s (make-instance 'sb-bsd-sockets:inet-socket
115             :type :stream
116             :protocol :tcp)))
117    (sb-bsd-sockets:socket-connect
118     s (car (sb-bsd-sockets:host-ent-addresses
119             (sb-bsd-sockets:get-host-by-name (url-host url))))
120     (url-port url))
121    (sb-bsd-sockets:socket-make-stream 
122     s
123     :input t 
124     :output t
125     :buffering :full
126     :external-format :iso-8859-1))
127  #+:cmu
128  (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
129                      :input t :output t :buffering :full)
130  #+:scl
131  (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
132                      :input t :output t :buffering :full
133          :external-format :iso-8859-1)
134  #+:lispworks
135  (comm:open-tcp-stream (url-host url) (url-port url)
136                        #+(and :lispworks :win32) :element-type
137                        #+(and :lispworks :win32) '(unsigned-byte 8))
138  #+:allegro
139  (socket:make-socket :remote-host (url-host url)
140                      :remote-port (url-port url))
141  #+:clisp
142  (socket:socket-connect (url-port url) (url-host url)
143                         :external-format
144                         (ext:make-encoding :charset 'charset:iso-8859-1 :line-terminator :unix))
145  #+:openmcl
146  (ccl:make-socket :remote-host (url-host url)
147                   :remote-port (url-port url))
148  #+:digitool
149  (ccl::open-tcp-stream (url-host url) (url-port url)
150                        :element-type 'unsigned-byte)
151
152  #+:abcl
153  (let ((socket 
154         (ext:make-socket (url-host url) (url-port url))))
155    (ext:get-socket-stream socket :external-format :iso-8859-1)))
156
157
158#+:sbcl
159(defun return-output-from-program (program args)
160  (with-output-to-string (out-stream)
161    (let ((proc (sb-ext:run-program
162                 program
163                 args
164                 :output out-stream
165                 :search t
166                 :wait t)))
167      (when (or (null proc)
168                (and (member (sb-ext:process-status proc) '(:exited :signaled))
169                     (not (zerop (sb-ext:process-exit-code proc)))))
170        (return-from return-output-from-program nil)))))
171
172#+(or :cmu :scl)
173(defun return-output-from-program (program args)
174  (with-output-to-string (out-stream)
175    (let ((proc (ext:run-program
176                 program
177                 args
178                 :output out-stream
179                 :wait t)))
180      (when (or (null proc)
181                (and (member (ext:process-status proc) '(:exited :signaled))
182                     (not (zerop (ext:process-exit-code proc)))))
183        (return-from return-output-from-program nil)))))
184
185#+:lispworks
186(defun return-output-from-program (program args)
187  (with-output-to-string (out-stream)
188    (unless (zerop (sys:call-system-showing-output
189                    (format nil #-:win32 "~A~{ '~A'~}"
190                            #+:win32 "~A~{ ~A~}"
191                            program args)
192                    :prefix ""
193                    :show-cmd nil
194                    :output-stream out-stream))
195      (return-from return-output-from-program nil))))
196
197#+(and :clisp (not :win32))
198(defun return-output-from-program (program args)
199  (with-output-to-string (out-stream)
200    (let ((stream
201           (ext:run-program program
202                            :arguments args
203                            :output :stream
204                            :wait nil)))
205      (loop for line = (read-line stream nil)
206            while line
207            do (write-line line out-stream)))))
208
209#+(and :clisp :win32)
210(defun return-output-from-program (program args)
211  (with-output-to-string (out-stream)
212    (let ((stream
213           (ext:run-shell-command
214            (format nil "~A~{ ~A~}" program args
215                    :output :stream
216                    :wait nil))))
217      (loop for line = (ignore-errors (read-line stream nil))
218            while line
219            do (write-line line out-stream)))))
220
221#+:allegro
222(defun return-output-from-program (program args)
223  (with-output-to-string (out-stream)
224    (let ((stream
225           (excl:run-shell-command
226            #-:mswindows
227            (concatenate 'vector
228                         (list program)
229                         (cons program args))
230            #+:mswindows
231            (format nil "~A~{ ~A~}" program args)
232            :output :stream
233            :wait nil)))
234      (loop for line = (read-line stream nil)
235            while line
236            do (write-line line out-stream)))))
237
238#+:ecl
239(defun return-output-from-program (program args)
240  (with-output-to-string (out-stream)
241    (let ((stream (ext:run-program program args :output :stream)))
242      (when stream
243  (loop for line = (ignore-errors (read-line stream nil))
244        while line
245        do (write-line line out-stream))))))
246
247#+:openmcl
248(defun return-output-from-program (program args)
249  (with-output-to-string (out-stream)
250    (let ((proc (ccl:run-program program args
251                                 :input nil
252                                 :output :stream
253                                 :wait nil)))
254      (loop for line = (read-line
255      (ccl:external-process-output-stream proc) nil nil nil)
256            while line
257            do (write-line line out-stream)))))
258
259#+:digitool
260(defun return-output-from-program (program args)
261  (ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args)))
262
263#+:abcl
264(defun return-output-from-program (program args) 
265  (let ((command (format nil "~A ~{ '~A' ~}" program args)))
266    (with-output-to-string (out-stream)
267      (ext:run-shell-command command :output out-stream))))
268   
269
270(defun unlink-file (pathname)
271  ;; 20070208 gwking@metabang.com - removed lisp-specific os-level calls
272  ;; in favor of a simple delete
273  (delete-file pathname))
274
275(defun symlink-files (old new)
276  (let* ((old (#-scl namestring #+scl ext:unix-namestring old))
277   (new (#-scl namestring #+scl ext:unix-namestring new #+scl nil))
278   ;; 20070811 - thanks to Juan Jose Garcia-Ripoll for pointing
279   ;; that ~a would wreck havoc if the working directory had a space
280   ;; in the pathname
281   (command (format nil "ln -s ~s ~s" old new)))
282    (format t "~S~%" command)
283    (shell-command command)))
284
285(defun maybe-symlink-sysfile (system sysfile)
286  (declare (ignorable system sysfile))
287  #-(or :win32 :mswindows)
288  (let ((target (merge-pathnames
289                 (make-pathname :name (pathname-name sysfile)
290                                :type (pathname-type sysfile))
291                 system)))
292    (when (probe-file target)
293      (unlink-file target))
294    (symlink-files sysfile target)))
295
296;;; ---------------------------------------------------------------------------
297;;; read-header-line
298;;; ---------------------------------------------------------------------------
299
300#-:digitool
301(defun read-header-line (stream)
302  (read-line stream))
303
304#+:digitool
305(defun read-header-line (stream &aux (line (make-array 16
306                                                       :element-type 'character
307                                                       :adjustable t
308                                                       :fill-pointer 0))
309                                (byte nil))
310  (print (multiple-value-bind (reader arg)
311                              (ccl::stream-reader stream)
312           (loop (setf byte (funcall reader arg))
313                 (case byte
314                   ((nil)
315                    (return))
316                   ((#.(char-code #\Return)
317                     #.(char-code #\Linefeed))
318                    (case (setf byte (funcall reader arg))
319                      ((nil #.(char-code #\Return) #.(char-code #\Linefeed)))
320                      (t (ccl:stream-untyi stream byte)))
321                    (return))
322                   (t
323                    (vector-push-extend (code-char byte) line))))
324           (when (or byte (plusp (length line)))
325             line))))
326
327(defun open-file-arguments ()
328  (append 
329   #+sbcl
330   '(:external-format :latin1)
331   #+:scl
332   '(:external-format :iso-8859-1)
333   #+abcl
334   '(:external-format :iso-8859-1)
335   #+(or :clisp :digitool (and :lispworks :win32))
336   '(:element-type (unsigned-byte 8))))
337
338(defun download-url-to-file (url file-name)
339  "Resolves url and then downloads it to file-name; returns the url actually used."
340  (multiple-value-bind (response headers stream)
341      (loop
342       (destructuring-bind (response headers stream)
343     (url-connection url)
344   (unless (member response '(301 302))
345     (return (values response headers stream)))
346   (close stream)
347   (setf url (header-value :location headers))))
348    (when (>= response 400)
349      (error 'download-error :url url :response response))
350    (let ((length (parse-integer (or (header-value :content-length headers) "")
351         :junk-allowed t)))
352      (installer-msg t "Downloading ~A bytes from ~A to ~A ..."
353         (or length "some unknown number of")
354         url
355         file-name)
356      (force-output)
357      #+:clisp (setf (stream-element-type stream)
358         '(unsigned-byte 8))
359      (let ((ok? nil) (o nil))
360  (unwind-protect
361       (progn
362         (setf o (apply #'open file-name 
363            :direction :output :if-exists :supersede
364            (open-file-arguments)))
365         #+(or :cmu :digitool)
366         (copy-stream stream o)
367         #-(or :cmu :digitool)
368         (if length
369       (let ((buf (make-array length
370            :element-type
371            (stream-element-type stream))))
372         #-:clisp (read-sequence buf stream)
373         #+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
374         (write-sequence buf o))
375       (copy-stream stream o))
376         (setf ok? t))
377    (when o (close o :abort (null ok?))))))
378    (close stream))
379  (values url))
380
381(defun download-url-to-temporary-file (url)
382  "Attempts to download url to a new, temporary file. Returns the resolved url and the file name \(as multiple values\)."
383  (let ((tmp (temp-file-name url)))
384    (pushnew tmp *temporary-files*)
385    (values (download-url-to-file url tmp) tmp)))
386
387(defun gpg-results (package signature)
388  (let ((tags nil))
389    (with-input-from-string
390  (gpg-stream 
391   (shell-command (format nil "~s --status-fd 1 --verify ~s ~s"
392                                *gpg-command*
393        (namestring signature) (namestring package))))
394      (loop for l = (read-line gpg-stream nil nil)
395   while l
396   do (print l)
397   when (> (mismatch l "[GNUPG:]") 6)
398   do (destructuring-bind (_ tag &rest data)
399    (split-sequence-if (lambda (x)
400             (find x '(#\Space #\Tab)))
401           l)
402        (declare (ignore _))
403        (pushnew (cons (intern (string-upcase tag) :keyword)
404           data) tags)))
405      tags)))
406
407#+allegro
408(defun shell-command (command)
409  (multiple-value-bind (output error status)
410                 (excl.osi:command-output command :whole t)
411    (values output error status)))
412
413#+clisp
414(defun shell-command (command)
415  ;; BUG: CLisp doesn't allow output to user-specified stream
416  (values
417   nil
418   nil
419   (ext:run-shell-command  command :output :terminal :wait t)))
420
421#+(or :cmu :scl)
422(defun shell-command (command)
423  (let* ((process (ext:run-program
424                   *shell-path*
425                   (list "-c" command)
426                   :input nil :output :stream :error :stream))
427         (output (file-to-string-as-lines (ext::process-output process)))
428         (error (file-to-string-as-lines (ext::process-error process))))
429    (close (ext::process-output process))
430    (close (ext::process-error process))
431    (values
432     output
433     error
434     (ext::process-exit-code process))))
435
436#+ecl
437(defun shell-command (command)
438  ;; If we use run-program, we do not get exit codes
439  (values nil nil (ext:system command)))
440
441#+lispworks
442(defun shell-command (command)
443  ;; BUG: Lispworks combines output and error streams
444  (let ((output (make-string-output-stream)))
445    (unwind-protect
446      (let ((status
447             (system:call-system-showing-output
448              command
449              :prefix ""
450              :show-cmd nil
451              :output-stream output)))
452        (values (get-output-stream-string output) nil status))
453      (close output))))
454
455#+openmcl
456(defun shell-command (command)
457  (let* ((process (create-shell-process command t))
458         (output (file-to-string-as-lines 
459                  (ccl::external-process-output-stream process)))
460         (error (file-to-string-as-lines
461                 (ccl::external-process-error-stream process))))
462    (close (ccl::external-process-output-stream process))
463    (close (ccl::external-process-error-stream process))
464    (values output
465            error
466            (process-exit-code process))))
467
468#+openmcl
469(defun create-shell-process (command wait)
470  (ccl:run-program
471   *shell-path*
472   (list "-c" command)
473   :input nil :output :stream :error :stream
474   :wait wait))
475
476#+openmcl
477(defun process-exit-code (process)
478  (nth-value 1 (ccl:external-process-status process)))
479
480#+digitool
481(defun shell-command (command)
482  ;; BUG: I have no idea what this returns
483  (ccl::call-system command))
484
485#+sbcl
486(defun shell-command (command)
487  (let* ((process (sb-ext:run-program
488                   *shell-path*
489                   (list "-c" command)
490                   :input nil :output :stream :error :stream))
491         (output (file-to-string-as-lines (sb-impl::process-output process)))
492         (error (file-to-string-as-lines (sb-impl::process-error process))))
493    (close (sb-impl::process-output process))
494    (close (sb-impl::process-error process))
495    (values
496     output
497     error
498     (sb-impl::process-exit-code process))))
499
500#+:abcl
501(defun shell-command (command)
502  (let* ((output (make-string-output-stream))
503         (status 
504          (ext:run-shell-command command :output output)))
505    (values (get-output-stream-string output) nil (format nil "~A" status))))
506
507(defgeneric file-to-string-as-lines (pathname)
508  (:documentation ""))
509
510(defmethod file-to-string-as-lines ((pathname pathname))
511  (with-open-file (stream pathname :direction :input)
512    (file-to-string-as-lines stream)))
513
514(defmethod file-to-string-as-lines ((stream stream))
515  (with-output-to-string (s)
516    (loop for line = (read-line stream nil :eof nil) 
517   until (eq line :eof) do
518   (princ line s)
519   (terpri s))))
520
521;; copied from ASDF
522(defun pathname-sans-name+type (pathname)
523  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
524and NIL NAME and TYPE components"
525  (make-pathname :name nil :type nil :defaults pathname))
526
Note: See TracBrowser for help on using the repository browser.