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

Last change on this file since 13035 was 13035, checked in by Mark Evenson, 11 years ago

[ticket #108][svn r13027] Fix download problems with ASDF-INSTALL.

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