source: trunk/source/tools/asdf-install/port.lisp @ 12898

Last change on this file since 12898 was 12898, checked in by rme, 10 years ago

Conditionalize SYSTEM-NAMESTRING for Clozure CL. Use SYSTEM-NAMESTRING
instead of NAMESTRING in several pertinent places. (see ticket:452)

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