source: release/1.2/source/tools/asdf-install/port.lisp @ 9219

Last change on this file since 9219 was 9219, checked in by gb, 11 years ago

synch from trunk

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