Changeset 9218


Ignore:
Timestamp:
Apr 20, 2008, 12:01:40 PM (11 years ago)
Author:
gb
Message:

newer upstream version

Location:
trunk/source/tools/asdf-install
Files:
8 added
9 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf-install/COPYRIGHT

    r2590 r9218  
    1515MK:DEFSYSTEM which includes the files load-asdf-install.lisp,
    1616loader.lisp, and finally split-sequence.lisp which has its own
    17 copyright notice.
     17copyright notice. ASDF-Install is currently maintained by Gary King
     18<gwking@metabang.com> and is hosted on Common-Lisp.net.
    1819
    1920The complete code distributed with this archive (asdf-install.tar.gz)
  • trunk/source/tools/asdf-install/asdf-install.asd

    r926 r9218  
    11;;; -*-  Lisp -*-
     2
     3;;; Portatble ASDF-Install is based on Dan Barlow's ASDF-Install
     4;; (see the file COPYRIGHT for details). It is currently maintained
     5;; by Gary King <gwking@metabang.com>.
    26
    37(defpackage #:asdf-install-system
     
    59
    610(in-package #:asdf-install-system)
    7 #+:sbcl
    8 (require 'sb-executable)
    9 
    10 ;;; this is appalling misuse of asdf.  please don't treat it as any
    11 ;;; kind of example.  this shouldn't be a compile-op, or if it is, should
    12 ;;; define output-files properly instead of leaving it be the fasl
    13 #+:sbcl
    14 (defclass exe-file (cl-source-file) ())
    15 #+:sbcl
    16 (defmethod perform :after ((o compile-op) (c exe-file))
    17   (sb-executable:make-executable
    18    (make-pathname :name "asdf-install"
    19                   :type nil
    20                   :defaults (component-pathname c))
    21    (output-files o c)
    22    :initial-function "RUN"))
    23 
    24 #+:sbcl
    25 (defmethod perform ((o load-op) (c exe-file)) nil)
    2611
    2712(defsystem asdf-install
    2813  #+:sbcl :depends-on
    29   #+:sbcl (sb-posix sb-bsd-sockets)
    30   :version "0.3"
     14  #+:sbcl (sb-bsd-sockets)
     15  :version "0.6.10"
     16  :author "Dan Barlow <dan@telent.net>, Edi Weitz <edi@agharta.de> and many others. See the file COPYRIGHT for more details."
     17  :maintainer "Gary Warren King <gwking@metabang.com>"
    3118  :components ((:file "defpackage")
    32                #+:sbcl
    33                (:exe-file "loader" :depends-on ("installer"))
    34                (:file "split-sequence")
     19               (:file "split-sequence" :depends-on ("defpackage"))
     20               
    3521               (:file "port" :depends-on ("defpackage"))
    3622               #+:digitool
    3723               (:file "digitool" :depends-on ("port"))
    38                (:file "installer" :depends-on ("port" "split-sequence" #+:digitool "digitool"))))
    39                
     24               
     25               (:file "conditions" :depends-on ("defpackage" "variables"))
     26               (:file "variables" :depends-on ("port"))
     27               (:file "installer"
     28                      :depends-on ("port" "split-sequence"
     29                                          #+:digitool "digitool"
     30                                          "conditions" "variables"))
     31               (:file "deprecated" :depends-on ("installer")))
     32  :in-order-to ((test-op (load-op test-asdf-install)))
     33  :perform (test-op :after (op c)
     34                    (funcall
     35                      (intern (symbol-name '#:run-tests) :lift)
     36                      :config :generic)))
     37           
    4038(defmethod perform :after ((o load-op) (c (eql (find-system :asdf-install))))
     39  (let ((show-version (find-symbol
     40                       (symbol-name '#:show-version-information)
     41                       '#:asdf-install)))
     42    (when (and show-version (fboundp show-version))
     43      (funcall show-version)))
    4144  (provide 'asdf-install))
    4245
     46(defmethod operation-done-p
     47    ((o test-op) (c (eql (find-system :asdf-install))))
     48  nil)
     49
     50#+(or)
    4351(defmethod perform ((o test-op) (c (eql (find-system :asdf-install))))
    4452  t)
  • trunk/source/tools/asdf-install/defpackage.lisp

    r2590 r9218  
    11(cl:in-package :cl-user)
    22
    3 (defpackage :asdf-install
    4   (:use "CL")
     3(defpackage #:asdf-install
     4  (:use #:common-lisp)
     5 
     6  #+asdf
     7  (:import-from #:asdf #:*defined-systems*)
    58  (:export
    69
    710   ;; Customizable variables.
     11   #:*shell-path*
    812   #:*proxy*
    913   #:*cclan-mirror*
    10    #:*sbcl-home* ; Deprecated.
    1114   #:asdf-install-dirs
    1215   #:private-asdf-install-dirs
     16   #:*tar-extractors*
    1317
     18   #:*shell-search-paths*
    1419   #:*verify-gpg-signatures*
    1520   #:*locations*
    1621   #:*safe-url-prefixes*
    1722   #:*preferred-location*
    18 
    19    #+(or :win32 :mswindows)
    20    #:*cygwin-bin-directory*
    21 
    22    #+(or :win32 :mswindows)
    23    #:*cygwin-bash-command*
    24 
     23   #:*temporary-directory*
     24   
    2525   ;; External entry points.   
    2626   #:add-locations
    27    #+(and asdf (or :win32 :mswindows))
    28    #:sysdef-source-dir-search
     27   #:add-registry-location
    2928   #:uninstall
    3029   #:install
     30   #:asdf-install-version
     31
     32   #+(and asdf (or :win32 :mswindows))
     33   #:sysdef-source-dir-search   
     34   
    3135   ;; proxy authentication
    3236   #:*proxy-user*
    33    #:*proxy-passwd*))
     37   #:*proxy-passwd*
     38   
     39   ;; conditions
     40   #:download-error
     41   #:signature-error
     42   #:gpg-error
     43   #:gpg-shell-error
     44   #:key-not-found
     45   #:key-not-trusted
     46   #:author-not-trusted
     47   #:installation-abort
    3448
    35 (defpackage :asdf-install-customize
    36   (:use "CL" "ASDF-INSTALL"))
     49   ;; restarts
     50   #:install-anyways
     51   )
     52 
     53  #+(or :win32 :mswindows)
     54  (:export
     55   #:*cygwin-bin-directory*
     56   #:*cygwin-bash-command*))
     57
     58(defpackage #:asdf-install-customize
     59  (:use #:common-lisp #:asdf-install))
  • trunk/source/tools/asdf-install/digitool.lisp

    r503 r9218  
    66;;; 2008-01-22 added exit-code checks to call-system
    77
    8 (in-package :asdf-install)
     8(in-package #:asdf-install)
    99
    1010#+:digitool
  • trunk/source/tools/asdf-install/installer.lisp

    r2590 r9218  
    1 (in-package :asdf-install)
     1(in-package #:asdf-install)
    22
    33(pushnew :asdf-install *features*)
    44
    55(defun installer-msg (stream format-control &rest format-arguments)
    6   (apply #'format stream ";;; ASDF-INSTALL: ~@?~%" format-control format-arguments))
    7 
    8 
    9 #+:digitool
    10 (defparameter *home-volume-name*
    11   (second (pathname-directory (truename (user-homedir-pathname))))
    12   "Digitool MCL retains the OS 9 convention that ALL volumes have a
    13 name which includes the startup volume. OS X doesn't know about this.
    14 This figures in the home path and in the normalization for system
    15 namestrings.")
    16 
    17 (defvar *proxy* (get-env-var "http_proxy"))
    18 
    19 (defvar *cclan-mirror*
    20   (or (get-env-var "CCLAN_MIRROR")
    21       "http://ftp.linux.org.uk/pub/lisp/cclan/"))
    22 
    23 #+(or :win32 :mswindows)
    24 (defvar *cygwin-bin-directory*
    25   (pathname "C:\\PROGRA~1\\Cygwin\\bin\\"))
    26 
    27 #+(or :win32 :mswindows)
    28 (defvar *cygwin-bash-program*
    29   "C:\\PROGRA~1\\Cygwin\\bin\\bash.exe")
    30 
    31 (defvar *gnu-tar-program*
    32   "tar"
    33   "Path to the GNU tar program")
    34 
    35 (eval-when (:compile-toplevel :load-toplevel :execute)
    36   (defparameter *supported-defsystems*
    37     (list :mk-defsystem
    38           :asdf
    39 
    40           ;; Add others.
    41           ;; #+lispworks :common-defsystem
    42           ))
    43          
    44 
    45   (unless (some (lambda (defsys-tag)
    46                   (member defsys-tag *features*))
    47                 *features*)
    48     (error "ASDF-INSTALL requires one of the following \"defsystem\" utilities to work."
    49            *supported-defsystems*)))
    50 
    51 
    52 
    53 (defun directorify (name)
    54   ;; input name may or may not have a trailing #\/, but we know we
    55   ;; want a directory
    56   (let ((path (pathname name)))
    57     (if (pathname-name path)
    58         (merge-pathnames
    59          (make-pathname :directory `(:relative ,(pathname-name path))
    60                         :name "")
    61          path)
    62         path)))
    63 
    64 (defvar *asdf-install-dirs*
    65   (directorify (or #+sbcl (get-env-var "SBCL_HOME")
    66                    (get-env-var "ASDF_INSTALL_DIR")
    67                    (make-pathname :directory
    68                                   `(:absolute
    69                                     #+digitool ,*home-volume-name*
    70                                     "usr" "local" "asdf-install")))))
    71 
    72 #+sbcl ; Deprecated.
    73 (define-symbol-macro *sbcl-home* *asdf-install-dirs*)
    74 
    75 
    76 (defvar *private-asdf-install-dirs*
    77   #+:sbcl
    78   (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
    79                    (truename (user-homedir-pathname)))
    80   #-:sbcl
    81   (cond ((get-env-var "PRIVATE_ASDF_INSTALL_DIR")
    82           (directorify (get-env-var "PRIVATE_ASDF_INSTALL_DIR")))
    83         (t
    84           (merge-pathnames (make-pathname :directory '(:relative ".asdf-install-dir"))
    85                            (truename (user-homedir-pathname))))))
    86 
    87 #+sbcl ; Deprecated.
    88 (define-symbol-macro *dot-sbcl* *private-asdf-install-dirs*)
    89 
    90 
    91 (defvar *trusted-uids* nil)
    92 
    93 (defvar *verify-gpg-signatures* t)
    94 
    95 (defvar *safe-url-prefixes* nil)
    96 
    97 (defvar *preferred-location* nil)
     6  (apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%"
     7         format-control format-arguments))
    988
    999(defun verify-gpg-signatures-p (url)
     
    10919      (t t))))
    11020         
    111 (defparameter *locations*
    112   `((,(merge-pathnames (make-pathname :directory '(:relative "site"))
    113                        *asdf-install-dirs*)
    114      ,(merge-pathnames (make-pathname :directory '(:relative "site-systems"))
    115                        *asdf-install-dirs*)
    116      "System-wide install")
    117     (,(merge-pathnames (make-pathname :directory '(:relative "site"))
    118                        *private-asdf-install-dirs*)
    119      ,(merge-pathnames (make-pathname :directory '(:relative "systems"))
    120                        *private-asdf-install-dirs*)
    121      "Personal installation")))
    122 
    123 
    124 #+(and (not :sbcl) :asdf)
    125 (pushnew `(merge-pathnames ,(make-pathname :directory '(:relative "site-systems"))
    126                            ,*asdf-install-dirs*)
    127          asdf:*central-registry*
    128          :test #'equal)
    129 
    130 #+(and (not :sbcl) :asdf)
    131 (pushnew `(merge-pathnames ,(make-pathname :directory '(:relative "systems"))
    132                            ,*private-asdf-install-dirs*)
    133          asdf:*central-registry*
    134          :test #'equal)
    135 
    136 #+mk-defsystem
    137 (mk:add-registry-location
    138  (merge-pathnames (make-pathname :directory '(:relative "site-systems"))
    139                   *private-asdf-install-dirs*))
    140 
    141 #+mk-defsystem
    142 (mk:add-registry-location
    143  (merge-pathnames (make-pathname :directory '(:relative "systems"))
    144                   *private-asdf-install-dirs*))
    145 
     21(defun same-central-registry-entry-p (a b)
     22  (flet ((ensure-string (x)
     23           (typecase x
     24             (string x)
     25             (pathname (namestring (translate-logical-pathname x)))
     26             (t nil))))
     27    (and (setf a (ensure-string a))
     28         (setf b (ensure-string b))
     29         a b (string-equal a b))))
     30
     31(defun add-registry-location (location)
     32  (let ((location-directory (pathname-sans-name+type location)))
     33    #+asdf
     34    (pushnew location-directory
     35             asdf:*central-registry*
     36             :test #'same-central-registry-entry-p)
     37 
     38    #+mk-defsystem
     39    (mk:add-registry-location location-directory)))
    14640
    14741;;; Fixing the handling of *LOCATIONS*
     
    16256        (append *locations* (list (list site system-site loc-name)))))
    16357
    164 
    165 
    166 (eval-when (:load-toplevel :execute)
    167   (let* ((*package* (find-package :asdf-install-customize))
    168          (file (probe-file (merge-pathnames
    169                             (make-pathname :name ".asdf-install")
    170                             (truename (user-homedir-pathname)))))
    171          )
    172     (when file (load file))))
    173 
    174 
    175 ;;;---------------------------------------------------------------------------
    176 ;;; Conditions.
    177 
    178 (define-condition download-error (error)
    179   ((url :initarg :url :reader download-url)
    180    (response :initarg :response :reader download-response))
    181   (:report (lambda (c s)
    182              (format s "Server responded ~A for GET ~A"
    183                      (download-response c) (download-url c)))))
    184 
    185 (define-condition signature-error (error)
    186   ((cause :initarg :cause :reader signature-error-cause))
    187   (:report (lambda (c s)
    188              (format s "Cannot verify package signature:  ~A"
    189                      (signature-error-cause c)))))
    190 
    191 (define-condition gpg-error (error)
    192   ((message :initarg :message :reader gpg-error-message))
    193   (:report (lambda (c s)
    194              (format s "GPG failed with error status:~%~S"
    195                      (gpg-error-message c)))))
    196 
    197 (define-condition no-signature (gpg-error) ())
    198 
    199 (define-condition key-not-found (gpg-error)
    200   ((key-id :initarg :key-id :reader key-id))
    201   (:report (lambda (c s)
    202              (format s "No key found for key id 0x~A. ~
    203                         Try some command like ~%  gpg  --recv-keys 0x~A"
    204                      (key-id c) (key-id c)))))
    205 
    206 (define-condition key-not-trusted (gpg-error)
    207   ((key-id :initarg :key-id :reader key-id)
    208    (key-user-name :initarg :key-user-name :reader key-user-name))
    209   (:report (lambda (c s)
    210              (format s "GPG warns that the key id 0x~A (~A) is not fully trusted"
    211                      (key-id c) (key-user-name c)))))
    212 
    213 (define-condition author-not-trusted (gpg-error)
    214   ((key-id :initarg :key-id :reader key-id)
    215    (key-user-name :initarg :key-user-name :reader key-user-name))
    216   (:report (lambda (c s)
    217              (format s "~A (key id ~A) is not on your package supplier list"
    218                      (key-user-name c) (key-id c)))))
    219  
    220 
    22158;;;---------------------------------------------------------------------------
    22259;;; URL handling.
     
    23269  (assert (string-equal url "http://" :end1 7))
    23370  (let ((port-start (position #\: url :start 7)))
    234     (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
     71    (if port-start
     72        (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
    23573
    23674; This is from Juri Pakaste's <juri@iki.fi> base64.lisp
     
    269107    result))
    270108
    271 (defvar *proxy-user* nil)
    272 (defvar *proxy-passwd* nil)
     109(defun request-uri (url)
     110  (assert (string-equal url "http://" :end1 7))
     111  (if *proxy*
     112      url
     113      (let ((path-start (position #\/ url :start 7)))
     114        (assert (and path-start) nil "url does not specify a file.")
     115        (subseq url path-start))))
    273116
    274117(defun url-connection (url)
     
    276119        (host (url-host url)))
    277120    (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C"
    278             url #\Return #\Linefeed
     121            (request-uri url) #\Return #\Linefeed
    279122            host #\Return #\Linefeed
    280123            *cclan-mirror* #\Return #\Linefeed)
     
    285128    (format stream "~C~C" #\Return #\Linefeed)
    286129    (force-output stream)
    287     (flet (#-:digitool
    288            (read-header-line ()
    289              (read-line stream))
    290            #+:digitool
    291            (read-header-line (&aux (line (make-array 16
    292                                                      :element-type 'character
    293                                                      :adjustable t
    294                                                      :fill-pointer 0))
    295                                    (byte nil))
    296              (print (multiple-value-bind (reader arg)
    297                         (ccl::stream-reader stream)
    298                       (loop (setf byte (funcall reader arg))
    299                             (case byte
    300                               ((nil)
    301                                 (return))
    302                               ((#.(char-code #\Return)
    303                                   #.(char-code #\Linefeed))
    304                                 (case (setf byte (funcall reader arg))
    305                                   ((nil #.(char-code #\Return) #.(char-code #\Linefeed)))
    306                                   (t (ccl:stream-untyi stream byte)))
    307                                 (return))
    308                               (t
    309                                 (vector-push-extend (code-char byte) line))))
    310                       (when (or byte (plusp (length line)))
    311                         line)))))
    312       (list
    313        (let* ((l (read-header-line))
    314               (space (position #\Space l)))
    315          (parse-integer l :start (1+ space) :junk-allowed t))
    316        (loop for line = (read-header-line)
    317              until (or (null line)
    318                        (zerop (length line))
    319                        (eql (elt line 0) (code-char 13)))
    320              collect
    321              (let ((colon (position #\: line)))
    322                (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
    323                      (string-trim (list #\Space (code-char 13))
    324                                   (subseq line (1+ colon))))))
    325        stream))))
    326 
    327 
    328 (defun download-files-for-package (package-name-or-url file-name)
    329   (let ((url (if (= (mismatch package-name-or-url "http://") 7)
    330                  package-name-or-url
    331                  (format nil "http://www.cliki.net/~A?download"
    332                          package-name-or-url)))
    333         )
    334     (destructuring-bind (response headers stream)
    335         (block got
    336           (loop
    337            (destructuring-bind (response headers stream) (url-connection url)
    338              (unless (member response '(301 302))             
    339                (return-from got (list response headers stream)))
    340              (close stream)
    341              (setf url (cdr (assoc :location headers))))))
    342       (when (>= response 400)
    343         (error 'download-error :url url :response response))
    344       (let ((length (parse-integer (or (cdr (assoc :content-length headers)) "")
    345                                    :junk-allowed t)))
    346         (installer-msg t "Downloading ~A bytes from ~A to ~A ..."
    347                        (or length "some unknown number of")
    348                        url
    349                        file-name)
    350         (force-output)
    351         #+:clisp (setf (stream-element-type stream)
    352                        '(unsigned-byte 8))
    353         (with-open-file (o file-name :direction :output
    354                            #+(or :clisp :digitool (and :lispworks :win32))
    355                            :element-type
    356                            #+(or :clisp :digitool (and :lispworks :win32))
    357                            '(unsigned-byte 8)
    358                            :if-exists :supersede)
    359           #+(or :cmu :digitool)
    360           (copy-stream stream o)
    361           #-(or :cmu :digitool)
    362           (if length
    363               (let ((buf (make-array length
    364                                      :element-type
    365                                      (stream-element-type stream))))
    366                 #-:clisp (read-sequence buf stream)
    367                 #+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
    368                 (write-sequence buf o))
    369               (copy-stream stream o))))
    370       (close stream)
    371       (terpri)
    372       (restart-case
    373           (verify-gpg-signature/url url file-name)
    374         (skip-gpg-check (&rest rest)
    375                         :report "Don't ckeck GPG signature for this package"
    376                         (declare (ignore rest))
    377                         nil)))))
    378 
    379 
    380 (defun read-until-eof (stream)
    381   (with-output-to-string (o)
    382     (copy-stream stream o)))
    383 
     130    (list
     131     (let* ((l (read-header-line stream))
     132            (space (position #\Space l)))
     133       (parse-integer l :start (1+ space) :junk-allowed t))
     134     (loop for line = (read-header-line stream)
     135           until (or (null line)
     136                     (zerop (length line))
     137                     (eql (elt line 0) (code-char 13)))
     138           collect
     139           (let ((colon (position #\: line)))
     140             (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
     141                   (string-trim (list #\Space (code-char 13))
     142                                (subseq line (1+ colon))))))
     143     stream)))
     144
     145(defun download-link-for-package (package-name-or-url)
     146  (if (= (mismatch package-name-or-url "http://") 7)
     147    package-name-or-url
     148    (format nil "http://www.cliki.net/~A?download"
     149            package-name-or-url)))
     150
     151(defun download-link-for-signature (url)
     152  (concatenate 'string url ".asc"))
     153
     154(defun download-files-for-package (package-name-or-url)
     155  (multiple-value-bind (package-url package-file)
     156      (download-url-to-temporary-file
     157       (download-link-for-package package-name-or-url))
     158    (if (verify-gpg-signatures-p package-name-or-url)
     159        (multiple-value-bind (signature-url signature-file)
     160            (download-url-to-temporary-file
     161             (download-link-for-signature package-url))
     162          (declare (ignore signature-url))
     163          (values package-file signature-file))
     164        (values package-file nil))))
    384165 
    385 (defun verify-gpg-signature/string (string file-name)
    386   (let ((gpg-stream (make-stream-from-gpg-command string file-name))
    387         tags)
    388     (unwind-protect
    389       (loop for l = (read-line gpg-stream nil nil)
    390             while l
    391             do (print l)
    392             when (> (mismatch l "[GNUPG:]") 6)
    393             do (destructuring-bind (_ tag &rest data)
    394                    (split-sequence:split-sequence-if (lambda (x)
    395                                                        (find x '(#\Space #\Tab)))
    396                                                      l)
    397                (declare (ignore _))
    398                (pushnew (cons (intern tag :keyword)
    399                               data) tags)))
    400       (ignore-errors
    401         (close gpg-stream)))
    402     ;; test for obvious key/sig problems
    403     (let ((errsig (assoc :errsig tags)))
    404       (and errsig (error 'key-not-found :key-id (second errsig))))
    405     (let ((badsig (assoc :badsig tags)))
    406       (and badsig (error 'key-not-found :key-id (second badsig))))
    407     (let* ((good (assoc :goodsig tags))
    408            (id (second good))
    409            (name (format nil "~{~A~^ ~}" (nthcdr 2 good))))
    410       ;; good signature, but perhaps not trusted
    411       (unless (or (assoc :trust_ultimate tags)
    412                   (assoc :trust_fully tags))
    413         (cerror "Install the package anyway"
    414                 'key-not-trusted
    415                 :key-user-name name
    416                 :key-id id))
    417       (loop
    418        (when
    419            (restart-case
    420                (or (assoc id *trusted-uids* :test #'equal)
    421                    (error 'author-not-trusted
    422                           :key-user-name name
    423                           :key-id id))
    424              (add-key (&rest rest)
    425                :report "Add to package supplier list"
    426                (declare (ignore rest))
    427                (pushnew (list id name) *trusted-uids*)))
    428          (return))))))
    429 
    430 
    431 (defun verify-gpg-signature/url (url file-name)
    432   (when (verify-gpg-signatures-p url)
    433     (destructuring-bind (response headers stream)
    434         (url-connection (concatenate 'string url ".asc"))
    435       (unwind-protect
    436         (flet (#-:digitool
    437                (read-signature (data stream)
    438                  (read-sequence data stream))
    439                #+:digitool
    440                (read-signature (data stream)
    441                  (multiple-value-bind (reader arg)
    442                      (ccl:stream-reader stream)
    443                    (let ((byte 0))
    444                      (dotimes (i (length data))
    445                        (unless (setf byte (funcall reader arg))
    446                          (error 'download-error :url  (concatenate 'string url ".asc")
    447                                 :response 200))
    448                        (setf (char data i) (code-char byte)))))))
    449           (if (= response 200)
    450             (let ((data (make-string (parse-integer
    451                                       (cdr (assoc :content-length headers))
    452                                       :junk-allowed t))))
    453               (read-signature data stream)
    454               (verify-gpg-signature/string data file-name))
    455             (error 'download-error :url  (concatenate 'string url ".asc")
    456                    :response response)))
    457         (close stream)))))
    458 
    459 
    460 (define-condition installation-abort (condition)
    461   ()
    462   (:report (lambda (c s)
    463              (declare (ignore c))
    464              (installer-msg s "Installation aborted."))))
    465 
    466 
    467 (defun where ()
     166(defun verify-gpg-signature (file-name signature-name)
     167  (block verify
     168    (loop
     169      (restart-case
     170          (let ((tags (gpg-results file-name signature-name)))
     171            ;; test that command returned something
     172            (unless tags
     173              (error 'gpg-shell-error))
     174            ;; test for obvious key/sig problems
     175            (let ((errsig (header-value :errsig tags)))
     176              (and errsig (error 'key-not-found :key-id errsig)))
     177            (let ((badsig (header-value :badsig tags)))
     178              (and badsig (error 'key-not-found :key-id badsig)))
     179            (let* ((good (header-value :goodsig tags))
     180                   (id (first good))
     181                   (name (format nil "~{~A~^ ~}" (rest good))))
     182              ;; good signature, but perhaps not trusted
     183              (restart-case
     184                  (let ((trusted? (or (header-pair :trust_ultimate tags)
     185                                      (header-pair :trust_fully tags)))
     186                        (in-list? (assoc id *trusted-uids* :test #'equal)))
     187                    (cond ((or trusted? in-list?)
     188                           ;; ok
     189                           )
     190                          ((not trusted?)
     191                           (error 'key-not-trusted
     192                                  :key-user-name name :key-id id))
     193                          ((not in-list?)
     194                           (error 'author-not-trusted
     195                                  :key-user-name name :key-id id))))
     196                (add-key (&rest rest)
     197                  :report "Add to package supplier list"
     198                  (declare (ignore rest))
     199                  (pushnew (list id name) *trusted-uids*))))
     200            (return-from verify t))
     201        (install-anyways
     202            (&rest rest)
     203          :report "Don't check GPG signature for this package"
     204          (declare (ignore rest))
     205          (return-from verify t))
     206        (retry-gpg-check
     207            (&rest args)
     208          :report "Retry GPG check \(e.g., after downloading the key\)"
     209          (declare (ignore args))
     210          nil)))))
     211
     212(defun header-value (name headers)
     213  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not."
     214  (cdr (header-pair name headers)))
     215
     216(defun header-pair (name headers)
     217  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not."
     218  (assoc name headers
     219         :test (lambda (a b)
     220                 (string-equal (symbol-name a) (symbol-name b)))))
     221
     222(defun validate-preferred-location ()
     223  (typecase *preferred-location*
     224    (null t)
     225    ((integer 0)
     226     (assert (<= 1 *preferred-location* (length *locations*))
     227             (*preferred-location*)
     228             'invalid-preferred-location-number-error
     229             :preferred-location *preferred-location*))
     230    ((or symbol string)
     231     (assert (find *preferred-location* *locations*
     232                   :test (if (typep *preferred-location* 'symbol)
     233                             #'eq #'string-equal) :key #'third)
     234             (*preferred-location*)
     235             'invalid-preferred-location-name-error
     236             :preferred-location *preferred-location*))
     237    (t
     238     (assert nil
     239             (*preferred-location*)
     240             'invalid-preferred-location-error
     241             :preferred-location *preferred-location*)))
     242  *preferred-location*)
     243
     244(defun select-location ()
    468245  (loop with n-locations = (length *locations*)
    469         for response = (or *preferred-location*             
    470                            (progn
    471                              (format t "Install where?~%")
    472                              (loop for (source system name) in *locations*
    473                                    for i from 0
    474                                    do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
    475                                               i name system source))
    476                              (format t "~D) Abort installation.~% --> " n-locations)
    477                              (force-output)
    478                              (read)))
    479         when (and (numberp response)
    480                   (<= 0 response (1- n-locations)))
    481            return (elt *locations* response)
    482         when (and (numberp response)
    483                   (= response n-locations))
    484            do (abort (make-condition 'installation-abort))))
     246     for response = (progn
     247                      (format t "Install where?~%")
     248                      (loop for (source system name) in *locations*
     249                         for i from 1
     250                         do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
     251                                    i name system source))
     252                      (format t "0) Abort installation.~% --> ")
     253                      (force-output)
     254                      (read))
     255     when (and (numberp response)
     256               (<= 1 response n-locations))
     257     return response
     258     when (and (numberp response)
     259               (zerop response))
     260     do (abort (make-condition 'installation-abort))))
     261
     262(defun install-location ()
     263  (validate-preferred-location)
     264  (let ((location-selection (or *preferred-location*
     265                                (select-location))))
     266    (etypecase location-selection
     267      (integer
     268       (elt *locations* (1- location-selection)))
     269      ((or symbol string)
     270       (find location-selection *locations* :key #'third
     271             :test (if (typep location-selection 'string)
     272                      #'string-equal #'eq))))))
    485273
    486274
    487275;;; install-package --
     276
     277(defun find-shell-command (command)
     278  (loop for directory in *shell-search-paths* do
     279       (let ((target (make-pathname :name command :type nil
     280                                    :directory directory)))
     281         (when (probe-file target)
     282           (return-from find-shell-command (namestring target)))))
     283  (values nil))
     284
     285(defun tar-command ()
     286  #-(or :win32 :mswindows)
     287  (find-shell-command *gnu-tar-program*)
     288  #+(or :win32 :mswindows)
     289  *cygwin-bash-program*)
     290
     291(defun tar-arguments (source packagename)
     292  #-(or :win32 :mswindows :scl)
     293  (list "-C" (namestring (truename source))
     294        "-xzvf" (namestring (truename packagename)))
     295  #+(or :win32 :mswindows)
     296  (list "-l"
     297        "-c"
     298        (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
     299                (namestring (truename source))
     300                (namestring (truename packagename))))
     301  #+scl
     302  (list "-C" (ext:unix-namestring (truename source))
     303        "-xzvf" (ext:unix-namestring (truename packagename))))
     304
     305(defun extract-using-tar (to-dir tarball)
     306  (let ((tar-command (tar-command)))
     307    (if (and tar-command (probe-file tar-command))
     308        (return-output-from-program tar-command
     309                                    (tar-arguments to-dir tarball))
     310        (warn "Cannot find tar command ~S." tar-command))))
     311
     312(defun extract (to-dir tarball)
     313  (or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
     314            *tar-extractors*)
     315      (error "Unable to extract tarball ~A." tarball)))
    488316
    489317(defun install-package (source system packagename)
     
    491319  (ensure-directories-exist source)
    492320  (ensure-directories-exist system)
    493   (let* ((tar
    494           (or #-(or :win32 :mswindows)
    495               (return-output-from-program *gnu-tar-program*
    496                                           (list "-C" (namestring (truename source))
    497                                                 "-xzvf" (namestring (truename packagename))))
    498               #+(or :win32 :mswindows)
    499               (return-output-from-program *cygwin-bash-program*
    500                                           (list "-l"
    501                                                 "-c"
    502                                                 (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
    503                                                         (namestring (truename source))
    504                                                         (namestring (truename packagename)))))
    505               (error "ASDF-INSTALL: can't untar ~S." packagename)))
     321  (let* ((tar (extract source packagename))
    506322         (pos-slash (or (position #\/ tar)
    507323                        (position #\Return tar)
     
    511327           (make-pathname :directory
    512328                          `(:relative ,(subseq tar 0 pos-slash)))
    513            source))
    514          )
    515     (princ tar)
     329           source)))
     330    ;(princ tar)
    516331    (loop for sysfile in (append
    517332                          (directory
    518                            (make-pathname :defaults (print *default-pathname-defaults*)
     333                           (make-pathname :defaults *default-pathname-defaults*
    519334                                          :name :wild
    520335                                          :type "asd"))
    521336                          (directory
    522                            (make-pathname :defaults (print *default-pathname-defaults*)
     337                           (make-pathname :defaults *default-pathname-defaults*
    523338                                          :name :wild
    524339                                          :type "system")))
    525           #-(or :win32 :mswindows)
    526           do
    527           #-(or :win32 :mswindows)
    528           (let ((target (merge-pathnames
    529                          (make-pathname :name (pathname-name sysfile)
    530                                         :type (pathname-type sysfile))
    531                          system)))
    532             (when (probe-file target)
    533               (unlink-file target))
    534             (symlink-files sysfile target))
    535           collect sysfile)))
    536 
    537 
    538 #| Original
    539 (defun install-package (source system packagename)
    540   "Returns a list of asdf system names for installed asdf systems"
    541   (ensure-directories-exist source)
    542   (ensure-directories-exist system)
    543   (let* ((tar
    544            (or
    545              #-(or :win32 :mswindows)
    546              (return-output-from-program "tar"
    547                                          (list "-C" (system-namestring source)
    548                                                "-xzvf" (system-namestring packagename)))
    549              #+(or :win32 :mswindows)
    550              (return-output-from-program "sh"
    551                                          (list "-c"
    552                                                (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
    553                                                        (namestring (truename source))
    554                                                        (namestring (truename packagename)))))
    555              (error "can't untar")))
    556          (pos-slash (position-if #'(lambda (c)
    557                                      (find c #(#\/ #\Return #\Linefeed)))
    558                                  tar))
    559          (*default-pathname-defaults*
    560           (merge-pathnames
    561            (make-pathname :directory
    562                           `(:relative ,(subseq tar 0 pos-slash)))
    563            source)))
    564     (princ tar)
    565     (loop for asd in (directory
    566                       (make-pathname :defaults (print *default-pathname-defaults*)
    567                                      :name :wild
    568                                      :type "asd"))
    569           #-(or :win32 :mswindows)
    570           do
    571           #-(or :win32 :mswindows)
    572           (let ((target (merge-pathnames
    573                          (make-pathname :name (pathname-name asd)
    574                                         :type (pathname-type asd))
    575                          system)))
    576             (when (probe-file target)
    577               (unlink-file target))
    578             (symlink-files asd target))
    579           collect (pathname-name asd))))
    580 |#
    581 
     340       do (maybe-symlink-sysfile system sysfile)
     341       do (installer-msg t "Found system definition: ~A" sysfile)
     342       do (maybe-update-central-registry sysfile)
     343       collect sysfile)))
     344
     345(defun maybe-update-central-registry (sysfile)
     346  ;; make sure that the systems we install are accessible in case
     347  ;; asdf-install:*locations* and asdf:*central-registry* are out
     348  ;; of sync
     349  (add-registry-location sysfile))
    582350
    583351(defun temp-file-name (p)
    584   (let* ((pos-slash (position #\/ p :from-end t))
    585          (pos-dot (position #\. p :start (or pos-slash 0))))
    586     (merge-pathnames
    587      (make-pathname
    588       :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
    589       :type "asdf-install-tmp")
    590      #+:clisp (user-homedir-pathname))))
     352  (declare (ignore p))
     353  (let ((pathname nil))
     354    (loop for i = 0 then (1+ i) do
     355         (setf pathname
     356               (merge-pathnames
     357                (make-pathname
     358                 :name (format nil "asdf-install-~d" i)
     359                 :type "asdf-install-tmp")
     360                *temporary-directory*))
     361         (unless (probe-file pathname)
     362           (return-from temp-file-name pathname)))))
    591363
    592364
     
    594366;;; This is the external entry point.
    595367
    596 (defun install (&rest packages)
    597   (let ((*temporary-files* nil)
    598         (*trusted-uids*
    599          (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    600            (when (probe-file p)
    601              (with-open-file (f p) (read f)))))
    602         ;; (installed-packages nil)
    603         )
     368(defun install (packages &key (propagate nil) (where *preferred-location*))
     369  (let* ((*preferred-location* where)
     370         (*temporary-files* nil)
     371         (trusted-uid-file
     372          (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
     373         (*trusted-uids*
     374          (when (probe-file trusted-uid-file)
     375            (with-open-file (f trusted-uid-file) (read f))))
     376         (old-uids (copy-list *trusted-uids*))
     377         #+asdf
     378         (*defined-systems* (if propagate
     379                              (make-hash-table :test 'equal)
     380                              *defined-systems*))
     381         (packages (if (atom packages) (list packages) packages))
     382         (*propagate-installation* propagate)
     383         (*systems-installed-this-time* nil))
    604384    (unwind-protect
    605         (destructuring-bind (source system name) (where)
    606           (declare (ignore name))
    607           (labels ((one-iter (packages)
    608                      (let ((installed-package-sysfiles
    609                             (loop for p in (mapcar #'string packages)
    610                                   unless
    611                                   #+(or :sbcl :alisp) (probe-file p)
    612                                   #-(or :sbcl :alisp) (and (/= (mismatch p "http://") 7)
    613                                                            (probe-file p))
    614                                   do (let ((tmp (temp-file-name p)))
    615                                        (pushnew tmp *temporary-files*)
    616                                        (download-files-for-package p tmp)
    617                                        (setf p tmp))
    618                                   end
    619                                   do (installer-msg t "Installing ~A in ~A, ~A"
    620                                                     p
    621                                                     source
    622                                                     system)
    623                                   append (install-package source
    624                                                           system
    625                                                           p)))
    626                            )
    627                      (dolist (sysfile installed-package-sysfiles)
    628                        (handler-bind
    629                            (
    630                            #+asdf
    631                            (asdf:missing-dependency
    632                             (lambda (c)
    633                               (installer-msg t
    634                                              "Downloading package ~A, required by ~A~%"
    635                                              (asdf::missing-requires c)
    636                                              (asdf:component-name
    637                                               (asdf::missing-required-by c)))
    638                               (one-iter (list
    639                                          (symbol-name
    640                                           (asdf::missing-requires c))))
    641                               (invoke-restart 'retry)))
    642 
    643                            #+mk-defsystem
    644                            (make:missing-component
    645                             (lambda (c)
    646                               (installer-msg t
    647                                              "Downloading package ~A, required by ~A~%"
    648                                            (make:missing-component-name c)
    649                                            (pathname-name sysfile) ; This should work.
    650                                            )
    651                               (one-iter (list (make:missing-component-name c)))
    652                               (invoke-restart 'retry)))
    653                             )
    654 
    655                          (loop (multiple-value-bind (ret restart-p)
    656                                    (with-simple-restart
    657                                        (retry "Retry installation")
    658                                      (load-system-definition sysfile))
    659                                  (declare (ignore ret))
    660                                  (unless restart-p (return))))
    661                          ))))
    662                    )
    663             (one-iter packages)))
    664       (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    665         (when (probe-file p)
    666           (with-open-file (out p
    667                                :direction :output
    668                                :if-exists :supersede)
    669             (with-standard-io-syntax
    670               (prin1 *trusted-uids* out)))))
     385      (destructuring-bind (source system name) (install-location)
     386        (declare (ignore name))
     387        (labels
     388            ((one-iter (packages)
     389               (let ((packages-to-install nil))
     390                 (loop for p in (mapcar #'string packages) do
     391                      (cond ((local-archive-p p)
     392                             (setf packages-to-install
     393                                   (append packages-to-install
     394                                           (install-package source system p))))
     395                            (t
     396                             (multiple-value-bind (package signature)
     397                                 (download-files-for-package p)
     398                               (when (verify-gpg-signatures-p p)
     399                                 (verify-gpg-signature package signature))
     400                               (installer-msg t "Installing ~A in ~A, ~A"
     401                                              p source system)
     402                               (install-package source system package))
     403                             (setf packages-to-install
     404                                   (append packages-to-install
     405                                           (list p))))))
     406                 (dolist (package packages-to-install)
     407                   (setf package
     408                         (etypecase package
     409                           (symbol package)
     410                           (string (intern package :asdf-install))
     411                           (pathname (intern
     412                                      (namestring (pathname-name package))
     413                                      :asdf-install))))
     414                   (handler-bind
     415                       (
     416                        #+asdf
     417                        (asdf:missing-dependency
     418                         (lambda (c)
     419                           (installer-msg
     420                            t
     421                            "Downloading package ~A, required by ~A~%"
     422                            (asdf::missing-requires c)
     423                            (asdf:component-name
     424                             (asdf::missing-required-by c)))
     425                           (one-iter
     426                            (list (asdf::coerce-name
     427                                   (asdf::missing-requires c))))
     428                           (invoke-restart 'retry)))
     429                        #+mk-defsystem
     430                        (make:missing-component
     431                         (lambda (c)
     432                           (installer-msg
     433                            t
     434                            "Downloading package ~A, required by ~A~%"
     435                            (make:missing-component-name c)
     436                            package)
     437                           (one-iter (list (make:missing-component-name c)))
     438                           (invoke-restart 'retry))))
     439                     (loop (multiple-value-bind (ret restart-p)
     440                               (with-simple-restart
     441                                   (retry "Retry installation")
     442                                 (push package *systems-installed-this-time*)
     443                                 (load-package package))
     444                             (declare (ignore ret))
     445                             (unless restart-p (return)))))))))
     446          (one-iter packages)))
     447      ;;; cleanup
     448      (unless (equal old-uids *trusted-uids*)
     449        (let ((create-file-p nil))
     450          (unless (probe-file trusted-uid-file)
     451            (installer-msg t "Trusted UID file ~A does not exist"
     452                           (namestring trusted-uid-file))
     453            (setf create-file-p
     454                  (y-or-n-p "Do you want to create the file?")))
     455          (when (or create-file-p (probe-file trusted-uid-file))
     456            (ensure-directories-exist trusted-uid-file)
     457            (with-open-file (out trusted-uid-file
     458                                 :direction :output
     459                                 :if-exists :supersede)
     460              (with-standard-io-syntax
     461                (prin1 *trusted-uids* out))))))
    671462      (dolist (l *temporary-files* t)
    672         (when (probe-file l) (delete-file l))))))
    673 
    674 
    675 (defun load-system-definition (sysfile)
    676   (declare (type pathname sysfile))
     463        (when (probe-file l) (delete-file l))))
     464    (nreverse *systems-installed-this-time*)))
     465
     466(defun local-archive-p (package)
     467  #+(or :sbcl :allegro) (probe-file package)
     468  #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
     469                           (probe-file package)))
     470
     471(defun load-package (package)
    677472  #+asdf
    678   (when (or (string-equal "asd" (pathname-type sysfile))
    679             (string-equal "asdf" (pathname-type sysfile)))
    680     (installer-msg t "Loading system ~S via ASDF." (pathname-name sysfile))
    681     (asdf:operate 'asdf:load-op (pathname-name sysfile)))
    682 
     473  (progn
     474    (installer-msg t "Loading system ~S via ASDF." package)
     475    (asdf:operate 'asdf:load-op package))
    683476  #+mk-defsystem
    684   (when (string-equal "system" (pathname-type sysfile))
    685     (installer-msg t "Loading system ~S via MK:DEFSYSTEM." (pathname-name sysfile))
    686     (mk:load-system (pathname-name sysfile))))
    687 
    688 
    689 #| Original.
    690 (defun install (&rest packages)
    691   (let ((*temporary-files* nil)
    692         (*trusted-uids*
    693          (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    694            (when (probe-file p)
    695              (with-open-file (f p) (read f))))))
    696     (unwind-protect
    697         (destructuring-bind (source system name) (where)
    698           (declare (ignore name))
    699           (labels ((one-iter (packages)
    700                      (dolist (asd
    701                               (loop for p in (mapcar 'string packages)
    702                                     unless #+(or :sbcl :alisp)
    703                                     (probe-file p)
    704                                     #-(or :sbcl :alisp)
    705                                     (and (/= (mismatch p "http://") 7)
    706                                          (probe-file p))
    707                                     do (let ((tmp (temp-file-name p)))
    708                                          (pushnew tmp *temporary-files*)
    709                                          (download-files-for-package p tmp)
    710                                          (setf p tmp))
    711                                     end
    712                                     do (format t "Installing ~A in ~A,~A~%"
    713                                                p source system)
    714                                     append (install-package source system p)))
    715                        (handler-bind
    716                            ((asdf:missing-dependency
    717                              (lambda (c)
    718                                (format t
    719                                        "Downloading package ~A, required by ~A~%"
    720                                        (asdf::missing-requires c)
    721                                        (asdf:component-name
    722                                         (asdf::missing-required-by c)))
    723                                (one-iter (list
    724                                           (symbol-name
    725                                            (asdf::missing-requires c))))
    726                                (invoke-restart 'retry))))
    727                          (loop
    728                           (multiple-value-bind (ret restart-p)
    729                               (with-simple-restart
    730                                   (retry "Retry installation")
    731                                 (asdf:operate 'asdf:load-op asd))
    732                             (declare (ignore ret))
    733                             (unless restart-p (return))))))))
    734             (one-iter packages)))
    735       (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    736         (with-open-file (out p :direction :output
    737                              :if-exists :supersede)
    738           (with-standard-io-syntax
    739             (prin1 *trusted-uids* out))))
    740       (dolist (l *temporary-files*)
    741         (when (probe-file l) (delete-file l))))))
    742 |#
    743 
     477  (progn
     478    (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
     479    (mk:load-system package)))
    744480
    745481;;; uninstall --
     
    749485  (let* ((asd (asdf:system-definition-pathname system))
    750486         (system (asdf:find-system system))
    751          (dir (asdf::pathname-sans-name+type
     487         (dir (pathname-sans-name+type
    752488               (asdf::resolve-symlinks asd))))
    753489    (when (or (not prompt)
     
    757493      #-(or :win32 :mswindows)
    758494      (delete-file asd)
    759       (asdf:run-shell-command "rm -r '~A'" (namestring (truename dir)))))
     495      (let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir))))
     496        (when dir
     497          (asdf:run-shell-command "rm -r '~A'" dir)))))
    760498
    761499  #+mk-defsystem
     
    777515      )))
    778516
    779 
    780 #| Original
    781 (defun uninstall (system &optional (prompt t))
    782   (let* ((asd (asdf:system-definition-pathname system))
    783          (system (asdf:find-system system))
    784          (dir (asdf::pathname-sans-name+type
    785                (asdf::resolve-symlinks asd))))
    786     (when (or (not prompt)
    787               (y-or-n-p
    788                "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
    789                system asd dir))
    790       #-(or :win32 :mswindows)
    791       (delete-file asd)
    792       (asdf:run-shell-command "rm -r '~A'" (namestring (truename dir))))))
    793 |#
    794 
    795517     
    796518;;; some day we will also do UPGRADE, but we need to sort out version
     
    814536            (return-from sysdef-source-dir-search file)))))))
    815537
     538(defmethod asdf:find-component :around
     539    ((module (eql nil)) name &optional version)
     540  (declare (ignore version))
     541  (when (or (not *propagate-installation*)
     542            (member name *systems-installed-this-time*
     543                    :test (lambda (a b)
     544                            (flet ((ensure-string (x)
     545                                     (etypecase x
     546                                       (symbol (symbol-name x))
     547                                       (string x))))
     548                              (string-equal (ensure-string a) (ensure-string b))))))
     549    (call-next-method)))
     550
     551(defun show-version-information ()
     552  (let ((version (asdf-install-version)))
     553    (if version
     554      (format *standard-output* "~&;;; ASDF-Install version ~A"
     555              version)
     556      (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
     557  (values)))
     558
     559(defun asdf-install-version ()
     560  "Returns the ASDf-Install version information as a string or nil if it cannot be determined."
     561  (let ((system (asdf:find-system 'asdf-install)))
     562    (when system (asdf:component-version system))))
     563
     564;; load customizations if any
     565(eval-when (:load-toplevel :execute)
     566  (let* ((*package* (find-package :asdf-install-customize))
     567         (file (probe-file (merge-pathnames
     568                            (make-pathname :name ".asdf-install")
     569                            (truename (user-homedir-pathname))))))
     570    (when file (load file))))
     571
    816572;;; end of file -- install.lisp --
  • trunk/source/tools/asdf-install/load-asdf-install.lisp

    r928 r9218  
    55
    66(eval-when (:load-toplevel :execute)
    7   (unless (find-package "ASDF-INSTALL-LOADER")
    8     (make-package "ASDF-INSTALL-LOADER" :use '("COMMON-LISP"))))
     7  (unless (find-package '#:asdf-install-loader)
     8    (make-package '#:asdf-install-loader :use '(#:common-lisp))))
    99
    10 (in-package "ASDF-INSTALL-LOADER")
     10(in-package :asdf-install-loader)
    1111
    1212(eval-when (:compile-toplevel :load-toplevel :execute)
     
    6767      (load-and-or-compile "ASDF-INSTALL-LIBRARY:port.lisp")
    6868
    69       (unless (find-package "SPLIT-SEQUENCE")
     69      (unless (find-package '#:split-sequence)
    7070        (load-and-or-compile "ASDF-INSTALL-LIBRARY:split-sequence.lisp"))
    7171
    72       #|
    73       ;; Implementation dependencies (in alphabetical order).
    74       #+allegro
    75       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;allegro.lisp")
     72      (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp")
    7673
    77       #+clisp
    78       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;clisp.lisp")
    79 
    80       #+(or cmu sbcl) ; They are still very similar.
    81       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;cmucl.lisp")
    82 
    83       #+digitool
    84       (load-and-or-compile "ASDF-INSTALL-LIBRARY:digitool.lisp")
    85 
    86       #+lcl
    87       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;lcl.lisp")
    88 
    89       #+lispworks
    90       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;lispworks.lisp")
    91       |#
    92 
    93 
    94       (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp")
    9574      ;; (load-and-or-compile "ASDF-INSTALL-LIBRARY:loader.lisp")
    9675
     
    10079
    10180  ;; To clean a minimum (and to make things difficult to debug)...
    102   ;; (delete-package "ASDF-INSTALL-LOADER")
     81  ;; (delete-package '#:asdf-install-loader)
    10382  )
    10483
  • trunk/source/tools/asdf-install/loader.lisp

    r503 r9218  
    33(eval-when (:load-toplevel)
    44  (unless (find-package 'asdf)
    5     (require 'asdf))
     5    (require 'asdf)))
     6
     7(eval-when (:load-toplevel)
     8  (unless (find-package 'asdf)
     9    (error "ASDF-Install requires ASDF to load"))   
    610  (let ((asdf::*verbose-out* nil))
    711    (require 'asdf-install)))
    812
     13#+sbcl
    914(defun run ()
    1015  (handler-case
  • trunk/source/tools/asdf-install/port.lisp

    r2590 r9218  
    1 (in-package :asdf-install)
     1(in-package #:asdf-install)
    22
    33(defvar *temporary-files*)
    44
     5(defparameter *shell-path* "/bin/sh"
     6  "The path to a Bourne compatible command shell in physical pathname notation.")
     7
    58(eval-when (:load-toplevel :compile-toplevel :execute)
    6   #+:lispworks
    7   (require "comm")
    89  #+:allegro
    910  (require :osi)
     
    1112  (require :socket)
    1213  #+:digitool
    13   (require :opentransport))
     14  (require :opentransport)
     15  #+:ecl
     16  (require :sockets)
     17  #+:lispworks
     18  (require "comm")
     19  )
    1420
    1521(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)
    1630  #+:sbcl (sb-ext:posix-getenv name)
    17   #+:cmu (cdr (assoc (intern (substitute #\_ #\- name)
    18                             :keyword)
    19                     ext:*environment-list*))
    20   #+:allegro (sys:getenv name)
    21   #+:lispworks (lw:environment-variable name)
    22   #+:clisp (ext:getenv name)
    23   #+(or :mcl :openmcl) (ccl::getenv name))
     31  #+:scl (cdr (assoc name ext:*environment-list* :test #'string=))
     32  )
    2433
    2534#-:digitool
     
    3948    (unless truename
    4049      (setf truename
    41               (translate-logical-pathname
    42                (merge-pathnames pathname *default-pathname-defaults*))))
     50            (translate-logical-pathname
     51             (merge-pathnames pathname *default-pathname-defaults*))))
    4352    (let ((directory (pathname-directory truename)))
    4453      (flet ((string-or-nil (value) (when (stringp value) value))
     
    6574
    6675;; for non-SBCL we just steal this from SB-EXECUTABLE
    67 #-(or :sbcl :digitool)
     76#-(or :digitool)
    6877(defvar *stream-buffer-size* 8192)
    69 #-(or :sbcl :digitool)
     78#-(or :digitool)
    7079(defun copy-stream (from to)
    7180  "Copy into TO from FROM until end of the input stream, in blocks of
     
    7685                         :element-type (stream-element-type from))))
    7786    (loop
    78      (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
    79                 #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
    80                 #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
    81        (when (zerop pos) (return))
    82        (write-sequence buf to :end pos)))))
     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)))))
    8392
    8493#+:digitool
     
    92101              (funcall writer writer-arg datum))))))
    93102
    94 #+:sbcl
    95 (declaim (inline copy-stream))
    96 #+:sbcl
    97 (defun copy-stream (from to)
    98   (sb-executable:copy-stream from to))
    99 
    100103(defun make-stream-from-url (url)
    101   #+:sbcl
     104  #+(or :sbcl :ecl)
    102105  (let ((s (make-instance 'sb-bsd-sockets:inet-socket
    103                           :type :stream
    104                           :protocol :tcp)))
     106             :type :stream
     107             :protocol :tcp)))
    105108    (sb-bsd-sockets:socket-connect
    106109     s (car (sb-bsd-sockets:host-ent-addresses
    107110             (sb-bsd-sockets:get-host-by-name (url-host url))))
    108111     (url-port url))
    109     (sb-bsd-sockets:socket-make-stream s :input t :output t :buffering :full))
     112    (sb-bsd-sockets:socket-make-stream
     113     s
     114     :input t
     115     :output t
     116     :buffering :full
     117     :external-format :iso-8859-1))
    110118  #+:cmu
    111119  (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
    112120                      :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)
    113125  #+:lispworks
    114126  (comm:open-tcp-stream (url-host url) (url-port url)
     
    129141                        :element-type 'unsigned-byte))
    130142
    131 #+(or :sbcl :cmu)
    132 (defun make-stream-from-gpg-command (string file-name)
    133   (#+:sbcl sb-ext:process-output
    134    #+:cmu ext:process-output
    135    (#+:sbcl sb-ext:run-program
    136     #+:cmu ext:run-program
    137     "gpg"
    138     (list
    139      "--status-fd" "1" "--verify" "-"
    140      (namestring file-name))
    141     :output :stream
    142     :error nil
    143     #+sbcl :search #+sbcl t
    144     :input (make-string-input-stream string)
    145     :wait t)))
    146 
    147 #+(and :lispworks (not :win32))
    148 (defun make-stream-from-gpg-command (string file-name)
    149   ;; kludge - we can't separate the in and out streams
    150   (let ((stream (sys:open-pipe (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
    151                                        string
    152                                        (namestring file-name)))))
    153     stream))
    154 
    155 (defun make-temp-sig (file-name content)
    156   (let ((name (format nil "~A.asc" (namestring (truename file-name)))))
    157     (with-open-file (out name
    158                          :direction :output
    159                          :if-exists :supersede)
    160       (write-string content out))
    161     (pushnew name *temporary-files*)
    162     name))
    163 
    164 #+(and :lispworks :win32)
    165 (defun make-stream-from-gpg-command (string file-name)
    166   (sys:open-pipe (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
    167                          (make-temp-sig file-name string)
    168                          (namestring file-name))))
    169 
    170 #+(and :clisp (not (or :win32 :cygwin)))
    171 (defun make-stream-from-gpg-command (string file-name)
    172   (let ((stream
    173           (ext:run-shell-command (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
    174                                          string
    175                                          (namestring file-name))
    176                            :output :stream
    177                            :wait nil)))
    178     stream))
    179 
    180 #+(and :clisp (or :win32 :cygwin))
    181 (defun make-stream-from-gpg-command (string file-name)
    182   (ext:run-shell-command (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
    183                                  (make-temp-sig file-name string)
    184                                  (namestring file-name))
    185                          :output :stream
    186                          :wait nil))
    187 
    188 #+:allegro
    189 (defun make-stream-from-gpg-command (string file-name)
    190   (multiple-value-bind (in-stream out-stream)
    191       (excl:run-shell-command
    192        #-:mswindows
    193        (concatenate 'vector
    194                     #("gpg" "gpg" "--status-fd" "1" "--verify" "-")
    195                     (make-sequence 'vector 1
    196                                    :initial-element (namestring file-name)))
    197        #+:mswindows
    198        (format nil "gpg --status-fd 1 --verify - \"~A\"" (namestring file-name))
    199        :input :stream
    200        :output :stream
    201        :separate-streams t
    202        :wait nil)
    203     (write-string string in-stream)
    204     (finish-output in-stream)
    205     (close in-stream)
    206     out-stream))
    207 
    208 #+:openmcl
    209 (defun make-stream-from-gpg-command (string file-name)
    210   (let ((proc (ccl:run-program "gpg" (list "--status-fd" "1" "--verify" "-" (namestring file-name))
    211                                :input :stream
    212                                :output :stream
    213                                :wait nil)))
    214     (write-string string (ccl:external-process-input-stream proc))
    215     (close (ccl:external-process-input-stream proc))
    216     (ccl:external-process-output-stream proc)))
    217 
    218 #+:digitool
    219 (defun make-stream-from-gpg-command (string file-name)
    220   (make-instance 'popen-input-stream
    221                  :command (format nil "echo '~A' | gpg --status-fd 1 --verify - '~A'"
    222                                   string
    223                                   (system-namestring file-name))))
    224143
    225144#+:sbcl
     
    230149                 args
    231150                 :output out-stream
     151                 :search t
    232152                 :wait t)))
    233153      (when (or (null proc)
     
    236156        (return-from return-output-from-program nil)))))
    237157
    238 #+:cmu
     158#+(or :cmu :scl)
    239159(defun return-output-from-program (program args)
    240160  (with-output-to-string (out-stream)
     
    254174    (unless (zerop (sys:call-system-showing-output
    255175                    (format nil #-:win32 "~A~{ '~A'~}"
    256                                 #+:win32 "~A~{ ~A~}"
    257                                 program args)
     176                            #+:win32 "~A~{ ~A~}"
     177                            program args)
    258178                    :prefix ""
    259179                    :show-cmd nil
     
    265185  (with-output-to-string (out-stream)
    266186    (let ((stream
    267             (ext:run-program program
    268                              :arguments args
    269                              :output :stream
    270                              :wait nil)))
     187           (ext:run-program program
     188                            :arguments args
     189                            :output :stream
     190                            :wait nil)))
    271191      (loop for line = (read-line stream nil)
    272192            while line
     
    277197  (with-output-to-string (out-stream)
    278198    (let ((stream
    279             (ext:run-shell-command
    280              (format nil "~A~{ ~A~}" program args
    281                      :output :stream
    282                      :wait nil))))
     199           (ext:run-shell-command
     200            (format nil "~A~{ ~A~}" program args
     201                    :output :stream
     202                    :wait nil))))
    283203      (loop for line = (ignore-errors (read-line stream nil))
    284204            while line
     
    289209  (with-output-to-string (out-stream)
    290210    (let ((stream
    291             (excl:run-shell-command
    292              #-:mswindows
    293              (concatenate 'vector
    294                           (list program)
    295                           (cons program args))
    296              #+:mswindows
    297              (format nil "~A~{ ~A~}" program args)
    298              :output :stream
    299              :wait nil)))
     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)))
    300220      (loop for line = (read-line stream nil)
    301221            while line
    302222            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))))))
    303232
    304233#+:openmcl
     
    309238                                 :output :stream
    310239                                 :wait nil)))
    311       (loop for line = (read-line (ccl:external-process-output-stream proc) nil nil nil)
     240      (loop for line = (read-line
     241                        (ccl:external-process-output-stream proc) nil nil nil)
    312242            while line
    313243            do (write-line line out-stream)))))
     
    317247  (ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args)))
    318248
    319 ;; why not just use DELETE-FILE?
    320249(defun unlink-file (pathname)
    321   #+:sbcl
    322   (sb-posix:unlink pathname)
    323   #+:cmu
    324   (unix:unix-unlink (namestring pathname))
    325   #+:allegro
    326   (excl.osi:unlink pathname)
    327   #+(or :lispwork :clisp :openmcl :digitool)
     250  ;; 20070208 gwking@metabang.com - removed lisp-specific os-level calls
     251  ;; in favor of a simple delete
    328252  (delete-file pathname))
    329253
    330254(defun symlink-files (old new)
    331   #+:sbcl
    332   (sb-posix:symlink old new)
    333   #+:cmu
    334   (unix:unix-symlink (namestring old)
    335                      (namestring new))
    336   #+:allegro
    337   (excl.osi:symlink old new)
    338   #+:lispworks
    339   ;; we loose if the pathnames contain apostrophes...
    340   (sys:call-system (format nil "ln -s '~A' '~A'"
    341                            (namestring old)
    342                            (namestring new)))
    343   #+:clisp
    344   (ext:run-program "ln"
    345                    :arguments (append '("-s")
    346                                       (list (format nil "~A" (namestring old))
    347                                             (format nil "~A" (namestring new)))))
    348   #+:openmcl
    349   (ccl:run-program "ln" (list "-s" (namestring old) (namestring new)))
    350   #+:digitool
    351   (ccl::call-system (format nil "ln -s '~A' '~A'"
    352                             (system-namestring old)
    353                             (system-namestring 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
  • trunk/source/tools/asdf-install/split-sequence.lisp

    r928 r9218  
    44;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
    55;;;
    6 ;;; changes include:
    7 ;;;
    8 ;;; * altering the behaviour of the :from-end keyword argument to
    9 ;;; return the subsequences in original order, for consistency with
    10 ;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
    11 ;;; affects the answer if :count is less than the number of
    12 ;;; subsequences, by analogy with the above-referenced functions).
    13 ;;;   
    14 ;;; * changing the :maximum keyword argument to :count, by analogy
    15 ;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
    16 ;;;
    17 ;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
    18 ;;; than SPLIT.
    19 ;;;
    20 ;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
    21 ;;;
    22 ;;; * The second return value is now an index rather than a copy of a
    23 ;;; portion of the sequence; this index is the `right' one to feed to
    24 ;;; CL:SUBSEQ for continued processing.
    256
    26 ;;; There's a certain amount of code duplication here, which is kept
    27 ;;; to illustrate the relationship between the SPLIT-SEQUENCE
    28 ;;; functions and the CL:POSITION functions.
    29 
    30 ;;; Examples:
    31 ;;;
    32 ;;; * (split-sequence #\; "a;;b;c")
    33 ;;; -> ("a" "" "b" "c"), 6
    34 ;;;
    35 ;;; * (split-sequence #\; "a;;b;c" :from-end t)
    36 ;;; -> ("a" "" "b" "c"), 0
    37 ;;;
    38 ;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
    39 ;;; -> ("c"), 4
    40 ;;;
    41 ;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
    42 ;;; -> ("a" "b" "c"), 6
    43 ;;;
    44 ;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
    45 ;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
    46 ;;;
    47 ;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
    48 ;;; -> ("ab" "a" "a" "ab" "a"), 11
    49 ;;;
    50 ;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
    51 ;;; -> ("oo" "bar" "b"), 9
    52 
    53 (defpackage "SPLIT-SEQUENCE"
    54   (:use "CL")
    55   (:nicknames "PARTITION")
    56   (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT"
    57            "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")
    58   (:documentation "The SPLIT-SEQUENCE package provides functionality for Common Lisp sequences analagous to Perl's split operator."))
    59 
    60 (in-package "SPLIT-SEQUENCE")
    61 
    62 (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
    63   "Return a list of subsequences in seq delimited by delimiter.
    64 
    65 If :remove-empty-subseqs is NIL, empty subsequences will be included
    66 in the result; otherwise they will be discarded.  All other keywords
    67 work analogously to those for CL:SUBSTITUTE.  In particular, the
    68 behaviour of :from-end is possibly different from other versions of
    69 this function; :from-end values of NIL and T are equivalent unless
    70 :count is supplied. The second return value is an index suitable as an
    71 argument to CL:SUBSEQ into the sequence indicating where processing
    72 stopped."
    73   (let ((len (length seq))
    74         (other-keys (nconc (when test-supplied
    75                              (list :test test))
    76                            (when test-not-supplied
    77                              (list :test-not test-not))
    78                            (when key-supplied
    79                              (list :key key)))))
    80     (unless end (setq end len))
    81     (if from-end
    82         (loop for right = end then left
    83               for left = (max (or (apply #'position delimiter seq
    84                                          :end right
    85                                          :from-end t
    86                                          other-keys)
    87                                   -1)
    88                               (1- start))
    89               unless (and (= right (1+ left))
    90                           remove-empty-subseqs) ; empty subseq we don't want
    91               if (and count (>= nr-elts count))
    92               ;; We can't take any more. Return now.
    93               return (values (nreverse subseqs) right)
    94               else
    95               collect (subseq seq (1+ left) right) into subseqs
    96               and sum 1 into nr-elts
    97               until (< left start)
    98               finally (return (values (nreverse subseqs) (1+ left))))
    99       (loop for left = start then (+ right 1)
    100             for right = (min (or (apply #'position delimiter seq
    101                                         :start left
    102                                         other-keys)
    103                                  len)
    104                              end)
    105             unless (and (= right left)
    106                         remove-empty-subseqs) ; empty subseq we don't want
    107             if (and count (>= nr-elts count))
    108             ;; We can't take any more. Return now.
    109             return (values subseqs left)
    110             else
    111             collect (subseq seq left right) into subseqs
    112             and sum 1 into nr-elts
    113             until (>= right end)
    114             finally (return (values subseqs right))))))
     7(in-package #:asdf-install)
    1158
    1169(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
     
    16558            finally (return (values subseqs right))))))
    16659
    167 (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
    168   "Return a list of subsequences in seq delimited by items satisfying
    169 (CL:COMPLEMENT predicate).
    170 
    171 If :remove-empty-subseqs is NIL, empty subsequences will be included
    172 in the result; otherwise they will be discarded.  All other keywords
    173 work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
    174 the behaviour of :from-end is possibly different from other versions
    175 of this function; :from-end values of NIL and T are equivalent unless
    176 :count is supplied. The second return value is an index suitable as an
    177 argument to CL:SUBSEQ into the sequence indicating where processing
    178 stopped."
    179   (let ((len (length seq))
    180         (other-keys (when key-supplied
    181                       (list :key key))))
    182     (unless end (setq end len))
    183     (if from-end
    184         (loop for right = end then left
    185               for left = (max (or (apply #'position-if-not predicate seq
    186                                          :end right
    187                                          :from-end t
    188                                          other-keys)
    189                                   -1)
    190                               (1- start))
    191               unless (and (= right (1+ left))
    192                           remove-empty-subseqs) ; empty subseq we don't want
    193               if (and count (>= nr-elts count))
    194               ;; We can't take any more. Return now.
    195               return (values (nreverse subseqs) right)
    196               else
    197               collect (subseq seq (1+ left) right) into subseqs
    198               and sum 1 into nr-elts
    199               until (< left start)
    200               finally (return (values (nreverse subseqs) (1+ left))))
    201       (loop for left = start then (+ right 1)
    202             for right = (min (or (apply #'position-if-not predicate seq
    203                                         :start left
    204                                         other-keys)
    205                                  len)
    206                              end)
    207             unless (and (= right left)
    208                         remove-empty-subseqs) ; empty subseq we don't want
    209             if (and count (>= nr-elts count))
    210             ;; We can't take any more. Return now.
    211             return (values subseqs left)
    212             else
    213             collect (subseq seq left right) into subseqs
    214             and sum 1 into nr-elts
    215             until (>= right end)
    216             finally (return (values subseqs right))))))
    217 
    218 ;;; clean deprecation
    219 
    220 (defun partition (&rest args)
    221   "PARTITION is deprecated; use SPLIT-SEQUENCE instead."
    222   (apply #'split-sequence args))
    223 
    224 (defun partition-if (&rest args)
    225   "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead."
    226   (apply #'split-sequence-if args))
    227 
    228 (defun partition-if-not (&rest args)
    229   "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead."
    230   (apply #'split-sequence-if-not args))
    231 
    232 (define-compiler-macro partition (&whole form &rest args)
    233   (declare (ignore args))
    234   (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
    235   form)
    236 
    237 (define-compiler-macro partition-if (&whole form &rest args)
    238   (declare (ignore args))
    239   (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
    240   form)
    241 
    242 (define-compiler-macro partition-if-not (&whole form &rest args)
    243   (declare (ignore args))
    244   (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
    245   form)
    246 
    247 (pushnew :split-sequence *features*)
Note: See TracChangeset for help on using the changeset viewer.