asdf-install.port.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl-contrib Show documentation
Show all versions of abcl-contrib Show documentation
Extra packages--contribs--for ABCL
The newest version!
(in-package #:asdf-install)
;;; 'port.lisp' is loaded before 'variables.lisp' primarily for the
;;; definiton of GET-ENV-VAR, but still needs the following specials
;;; which would otherwise be in 'variables.lisp'.
(defparameter *shell-path* "/bin/sh"
"The path to a Bourne compatible command shell in physical pathname notation.")
(defvar *gpg-command* "gpg"
"Location of the gpg binary, if for some reason, it does not appear
in the default path for /bin/sh.")
;;; End variables
(defvar *temporary-files*)
(eval-when (:load-toplevel :compile-toplevel :execute)
#+:allegro
(require :osi)
#+:allegro
(require :socket)
#+:digitool
(require :opentransport)
#+:ecl
(require :sockets)
#+:lispworks
(require "comm")
)
(defun get-env-var (name)
#+:allegro (sys:getenv name)
#+:clisp (ext:getenv name)
#+:cmu (cdr (assoc (intern (substitute #\_ #\- name)
:keyword)
ext:*environment-list*))
#+:ecl (ext:getenv name)
#+:lispworks (lw:environment-variable name)
#+(or :mcl :openmcl) (ccl::getenv name)
#+:sbcl (sb-ext:posix-getenv name)
#+:scl (cdr (assoc name ext:*environment-list* :test #'string=))
#+abcl (ext:getenv name)
)
#-:digitool
(defun system-namestring (pathname)
(namestring (truename pathname)))
#+:digitool
(defvar *start-up-volume*
(second (pathname-directory (truename "ccl:"))))
#+:digitool
(defun system-namestring (pathname)
;; this tries to adjust the root directory to eliminate the spurious
;; volume name for the boot file system; it also avoids use of
;; TRUENAME as some applications are for not yet existent files
(let ((truename (probe-file pathname)))
(unless truename
(setf truename
(translate-logical-pathname
(merge-pathnames pathname *default-pathname-defaults*))))
(let ((directory (pathname-directory truename)))
(flet ((string-or-nil (value) (when (stringp value) value))
(absolute-p (directory) (eq (first directory) :absolute))
(root-volume-p (directory)
(equal *start-up-volume* (second directory))))
(format nil "~:[~;/~]~{~a/~}~@[~a~]~@[.~a~]"
(absolute-p directory)
(if (root-volume-p directory) (cddr directory) (cdr directory))
(string-or-nil (pathname-name truename))
(string-or-nil (pathname-type truename)))))))
#+:digitool
(progn
(defun |read-linefeed-eol-comment|
(stream char &optional (eol '(#\return #\linefeed)))
(loop (setf char (read-char stream nil nil))
(unless char (return))
(when (find char eol) (return)))
(values))
(set-syntax-from-char #\linefeed #\space)
(set-macro-character #\; #'|read-linefeed-eol-comment| nil *readtable*))
;; for non-SBCL we just steal this from SB-EXECUTABLE
#-(or :digitool)
(defvar *stream-buffer-size* 8192)
#-(or :digitool)
(defun copy-stream (from to)
"Copy into TO from FROM until end of the input stream, in blocks of
*stream-buffer-size*. The streams should have the same element type."
(unless (subtypep (stream-element-type to) (stream-element-type from))
(error "Incompatible streams ~A and ~A." from to))
(let ((buf (make-array *stream-buffer-size*
:element-type (stream-element-type from))))
(loop
(let ((pos #-(or :clisp :cmu) (read-sequence buf from)
#+:clisp (ext:read-byte-sequence buf from :no-hang nil)
#+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
(when (zerop pos) (return))
(write-sequence buf to :end pos)))))
#+:digitool
(defun copy-stream (from to)
"Perform copy and map EOL mode."
(multiple-value-bind (reader reader-arg) (ccl::stream-reader from)
(multiple-value-bind (writer writer-arg) (ccl::stream-writer to)
(let ((datum nil))
(loop (unless (setf datum (funcall reader reader-arg))
(return))
(funcall writer writer-arg datum))))))
(defun make-stream-from-url (url)
#+(or :sbcl :ecl)
(let ((s (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(sb-bsd-sockets:socket-connect
s (car (sb-bsd-sockets:host-ent-addresses
(sb-bsd-sockets:get-host-by-name (url-host url))))
(url-port url))
(sb-bsd-sockets:socket-make-stream
s
:input t
:output t
:buffering :full
:external-format :iso-8859-1))
#+:cmu
(sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
:input t :output t :buffering :full)
#+:scl
(sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
:input t :output t :buffering :full
:external-format :iso-8859-1)
#+:lispworks
(comm:open-tcp-stream (url-host url) (url-port url)
#+(and :lispworks :win32) :element-type
#+(and :lispworks :win32) '(unsigned-byte 8))
#+:allegro
(socket:make-socket :remote-host (url-host url)
:remote-port (url-port url))
#+:clisp
(socket:socket-connect (url-port url) (url-host url)
:external-format
(ext:make-encoding :charset 'charset:iso-8859-1 :line-terminator :unix))
#+:openmcl
(ccl:make-socket :remote-host (url-host url)
:remote-port (url-port url))
#+:digitool
(ccl::open-tcp-stream (url-host url) (url-port url)
:element-type 'unsigned-byte)
#+:abcl
(let ((socket
(ext:make-socket (url-host url) (url-port url))))
(ext:get-socket-stream socket :external-format :iso-8859-1)))
#+:sbcl
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((proc (sb-ext:run-program
program
args
:output out-stream
:search t
:wait t)))
(when (or (null proc)
(and (member (sb-ext:process-status proc) '(:exited :signaled))
(not (zerop (sb-ext:process-exit-code proc)))))
(return-from return-output-from-program nil)))))
#+(or :cmu :scl)
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((proc (ext:run-program
program
args
:output out-stream
:wait t)))
(when (or (null proc)
(and (member (ext:process-status proc) '(:exited :signaled))
(not (zerop (ext:process-exit-code proc)))))
(return-from return-output-from-program nil)))))
#+:lispworks
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(unless (zerop (sys:call-system-showing-output
(format nil #-:win32 "~A~{ '~A'~}"
#+:win32 "~A~{ ~A~}"
program args)
:prefix ""
:show-cmd nil
:output-stream out-stream))
(return-from return-output-from-program nil))))
#+(and :clisp (not :win32))
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((stream
(ext:run-program program
:arguments args
:output :stream
:wait nil)))
(loop for line = (read-line stream nil)
while line
do (write-line line out-stream)))))
#+(and :clisp :win32)
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((stream
(ext:run-shell-command
(format nil "~A~{ ~A~}" program args
:output :stream
:wait nil))))
(loop for line = (ignore-errors (read-line stream nil))
while line
do (write-line line out-stream)))))
#+:allegro
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((stream
(excl:run-shell-command
#-:mswindows
(concatenate 'vector
(list program)
(cons program args))
#+:mswindows
(format nil "~A~{ ~A~}" program args)
:output :stream
:wait nil)))
(loop for line = (read-line stream nil)
while line
do (write-line line out-stream)))))
#+:ecl
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((stream (ext:run-program program args :output :stream)))
(when stream
(loop for line = (ignore-errors (read-line stream nil))
while line
do (write-line line out-stream))))))
#+:openmcl
(defun return-output-from-program (program args)
(with-output-to-string (out-stream)
(let ((proc (ccl:run-program program args
:input nil
:output :stream
:wait nil)))
(loop for line = (read-line
(ccl:external-process-output-stream proc) nil nil nil)
while line
do (write-line line out-stream)))))
#+:digitool
(defun return-output-from-program (program args)
(ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args)))
#+:abcl
(defun return-output-from-program (program args)
(let ((command (format nil "~A ~{ '~A' ~}" program args)))
(with-output-to-string (out-stream)
(ext:run-shell-command command :output out-stream))))
(defun unlink-file (pathname)
;; 20070208 [email protected] - removed lisp-specific os-level calls
;; in favor of a simple delete
(delete-file pathname))
(defun symlink-files (old new)
(let* ((old (#-scl namestring #+scl ext:unix-namestring old))
(new (#-scl namestring #+scl ext:unix-namestring new #+scl nil))
;; 20070811 - thanks to Juan Jose Garcia-Ripoll for pointing
;; that ~a would wreck havoc if the working directory had a space
;; in the pathname
(command (format nil "ln -s ~s ~s" old new)))
(format t "~S~%" command)
(shell-command command)))
(defun maybe-symlink-sysfile (system sysfile)
(declare (ignorable system sysfile))
#-(or :win32 :mswindows)
(let ((target (merge-pathnames
(make-pathname :name (pathname-name sysfile)
:type (pathname-type sysfile))
system)))
(when (probe-file target)
(unlink-file target))
(symlink-files sysfile target)))
;;; ---------------------------------------------------------------------------
;;; read-header-line
;;; ---------------------------------------------------------------------------
#-:digitool
(defun read-header-line (stream)
(read-line stream))
#+:digitool
(defun read-header-line (stream &aux (line (make-array 16
:element-type 'character
:adjustable t
:fill-pointer 0))
(byte nil))
(print (multiple-value-bind (reader arg)
(ccl::stream-reader stream)
(loop (setf byte (funcall reader arg))
(case byte
((nil)
(return))
((#.(char-code #\Return)
#.(char-code #\Linefeed))
(case (setf byte (funcall reader arg))
((nil #.(char-code #\Return) #.(char-code #\Linefeed)))
(t (ccl:stream-untyi stream byte)))
(return))
(t
(vector-push-extend (code-char byte) line))))
(when (or byte (plusp (length line)))
line))))
(defun open-file-arguments ()
(append
#+sbcl
'(:external-format :latin1)
#+:scl
'(:external-format :iso-8859-1)
#+abcl
'(:external-format :iso-8859-1)
#+(or :clisp :digitool (and :lispworks :win32))
'(:element-type (unsigned-byte 8))))
(defun download-url-to-file (url file-name)
"Resolves url and then downloads it to file-name; returns the url actually used."
(multiple-value-bind (response headers stream)
(loop
(destructuring-bind (response headers stream)
(url-connection url)
(unless (member response '(301 302))
(return (values response headers stream)))
(close stream)
(setf url (header-value :location headers))))
(when (>= response 400)
(error 'download-error :url url :response response))
(let ((length (parse-integer (or (header-value :content-length headers) "")
:junk-allowed t)))
(installer-msg t "Downloading ~A bytes from ~A to ~A ..."
(or length "some unknown number of")
url
file-name)
(force-output)
#+:clisp (setf (stream-element-type stream)
'(unsigned-byte 8))
(let ((ok? nil) (o nil))
(unwind-protect
(progn
(setf o (apply #'open file-name
:direction :output :if-exists :supersede
(open-file-arguments)))
#+(or :cmu :digitool)
(copy-stream stream o)
#-(or :cmu :digitool)
(if length
(let ((buf (make-array length
:element-type
(stream-element-type stream))))
#-:clisp (read-sequence buf stream)
#+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
(write-sequence buf o))
(copy-stream stream o))
(setf ok? t))
(when o (close o :abort (null ok?))))))
(close stream))
(values url))
(defun download-url-to-temporary-file (url)
"Attempts to download url to a new, temporary file. Returns the resolved url and the file name \(as multiple values\)."
(let ((tmp (temp-file-name url)))
(pushnew tmp *temporary-files*)
(values (download-url-to-file url tmp) tmp)))
(defun gpg-command ()
(find-shell-command *gpg-command*))
(defun gpg-results (package signature)
(let ((tags nil))
(with-input-from-string
(gpg-stream
(shell-command (format nil "~s --status-fd 1 --verify ~s ~s"
(gpg-command)
(namestring signature) (namestring package))))
(loop for l = (read-line gpg-stream nil nil)
while l
do (print l)
when (> (mismatch l "[GNUPG:]") 6)
do (destructuring-bind (_ tag &rest data)
(split-sequence-if (lambda (x)
(find x '(#\Space #\Tab)))
l)
(declare (ignore _))
(pushnew (cons (intern (string-upcase tag) :keyword)
data) tags)))
tags)))
#+allegro
(defun shell-command (command)
(multiple-value-bind (output error status)
(excl.osi:command-output command :whole t)
(values output error status)))
#+clisp
(defun shell-command (command)
;; BUG: CLisp doesn't allow output to user-specified stream
(values
nil
nil
(ext:run-shell-command command :output :terminal :wait t)))
#+(or :cmu :scl)
(defun shell-command (command)
(let* ((process (ext:run-program
*shell-path*
(list "-c" command)
:input nil :output :stream :error :stream))
(output (file-to-string-as-lines (ext::process-output process)))
(error (file-to-string-as-lines (ext::process-error process))))
(close (ext::process-output process))
(close (ext::process-error process))
(values
output
error
(ext::process-exit-code process))))
#+ecl
(defun shell-command (command)
;; If we use run-program, we do not get exit codes
(values nil nil (ext:system command)))
#+lispworks
(defun shell-command (command)
;; BUG: Lispworks combines output and error streams
(let ((output (make-string-output-stream)))
(unwind-protect
(let ((status
(system:call-system-showing-output
command
:prefix ""
:show-cmd nil
:output-stream output)))
(values (get-output-stream-string output) nil status))
(close output))))
#+openmcl
(defun shell-command (command)
(let* ((process (create-shell-process command t))
(output (file-to-string-as-lines
(ccl::external-process-output-stream process)))
(error (file-to-string-as-lines
(ccl::external-process-error-stream process))))
(close (ccl::external-process-output-stream process))
(close (ccl::external-process-error-stream process))
(values output
error
(process-exit-code process))))
#+openmcl
(defun create-shell-process (command wait)
(ccl:run-program
*shell-path*
(list "-c" command)
:input nil :output :stream :error :stream
:wait wait))
#+openmcl
(defun process-exit-code (process)
(nth-value 1 (ccl:external-process-status process)))
#+digitool
(defun shell-command (command)
;; BUG: I have no idea what this returns
(ccl::call-system command))
#+sbcl
(defun shell-command (command)
(let* ((process (sb-ext:run-program
*shell-path*
(list "-c" command)
:input nil :output :stream :error :stream))
(output (file-to-string-as-lines (sb-impl::process-output process)))
(error (file-to-string-as-lines (sb-impl::process-error process))))
(close (sb-impl::process-output process))
(close (sb-impl::process-error process))
(values
output
error
(sb-impl::process-exit-code process))))
#+:abcl
(defun shell-command (command)
(let* ((output (make-string-output-stream))
(status
(ext:run-shell-command command :output output)))
(values (get-output-stream-string output) nil (format nil "~A" status))))
(defgeneric file-to-string-as-lines (pathname)
(:documentation ""))
(defmethod file-to-string-as-lines ((pathname pathname))
(with-open-file (stream pathname :direction :input)
(file-to-string-as-lines stream)))
(defmethod file-to-string-as-lines ((stream stream))
(with-output-to-string (s)
(loop for line = (read-line stream nil :eof nil)
until (eq line :eof) do
(princ line s)
(terpri s))))
;; copied from ASDF
(defun pathname-sans-name+type (pathname)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME and TYPE components"
(make-pathname :name nil :type nil :defaults pathname))
© 2015 - 2025 Weber Informatics LLC | Privacy Policy