backward-interface.lisp 10.7 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces

(defpackage :asdf/backward-interface
  (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os
   :asdf/component :asdf/system :asdf/operation :asdf/action
   :asdf/lisp-build :asdf/operate :asdf/output-translations)
  (:export
   #:*asdf-verbose*
   #:component-load-dependencies
   #:enable-asdf-binary-locations-compatibility
   #:merge-component-name-type
   #:operation-forced
   #:operation-on-failure
   #:operation-on-warnings
   #:run-shell-command
   #:system-definition-pathname))

(in-package :asdf/backward-interface)

(defvar *asdf-verbose* nil) ; worked around by cl-protobufs. It was a mistake to introduce it. mea culpa -fare

(defun* component-load-dependencies (component)
  ;; Old deprecated name for the same thing. Please update your software.
  (component-sibling-dependencies component))

(defun* merge-component-name-type (name &key type defaults)
  ;; For backward-compatibility only, for people using internals.
  ;; Will be removed in a future release, e.g. 2.016.
  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
  (coerce-pathname name :type type :defaults defaults))

(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))

(defgeneric* operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation))
#-gcl<2.7 (defgeneric* (setf operation-on-warnings) (x operation))
#-gcl<2.7 (defgeneric* (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
  (declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
  (declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
  (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
  (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))

(defun* system-definition-pathname (x)
  ;; As of 2.014.8, we mean to make this function obsolete,
  ;; but that won't happen until all clients have been updated.
  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
It used to expose ASDF internals with subtle differences with respect to
user expectations, that have been refactored away since.
We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;)
  (system-source-file x))


;;;; ASDF-Binary-Locations compatibility

(defun* enable-asdf-binary-locations-compatibility
    (&key
     (centralize-lisp-binaries nil)
     (default-toplevel-directory
         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
     (include-per-user-information nil)
     (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
     (source-to-target-mappings nil))
  #+(or clisp ecl mkcl)
  (when (null map-all-source-files)
    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
  (let* ((fasl-type (fasl-type))
         (mapped-files (if map-all-source-files *wild-file*
                           (make-pathname :type fasl-type :defaults *wild-file*)))
         (destination-directory
          (if centralize-lisp-binaries
              `(,default-toplevel-directory
                ,@(when include-per-user-information
                        (cdr (pathname-directory (user-homedir))))
                :implementation ,*wild-inferiors*)
              `(:root ,*wild-inferiors* :implementation))))
    (initialize-output-translations
     `(:output-translations
       ,@source-to-target-mappings
       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
       #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
       ((:root ,*wild-inferiors* ,mapped-files)
        (,@destination-directory ,mapped-files))
       (t t)
       :ignore-inherited-configuration))))

(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
  (declare (ignorable operation-class system args))
  (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
In case you insist on preserving your previous A-B-L configuration, but
do not know how to achieve the same effect with A-O-T, you may use function
ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
call that function where you would otherwise have loaded and configured A-B-L.")))


;;;; run-shell-command
;;
;; run-shell-command functions for other lisp implementations will be
;; gratefully accepted, if they do the same thing.
;; If the docstring is ambiguous, send a bug report.
;;
;; WARNING! The function below is mostly dysfunctional.
;; For instance, it will probably run fine on most implementations on Unix,
;; which will hopefully use the shell /bin/sh (which we force in some cases)
;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
;; But behavior on Windows may vary wildly between implementations,
;; either relying on your having installed a POSIX sh, or going through
;; the CMD.EXE interpreter, for a totally different meaning, depending on
;; what is easily expressible in said implementation.
;;
;; We probably should move this functionality to its own system and deprecate
;; use of it from the asdf package. However, this would break unspecified
;; existing software, so until a clear alternative exists, we can't deprecate
;; it, and even after it's been deprecated, we will support it for a few
;; years so everyone has time to migrate away from it. -- fare 2009-12-01
;;
;; As a suggested replacement which is portable to all ASDF-supported
;; implementations and operating systems except Genera, I recommend
;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.

(defun* run-shell-command (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*.  Returns the shell's exit code."
  (let ((command (apply 'format nil control-string args)))
    (asdf-message "; $ ~A~%" command)

    #+abcl
    (ext:run-shell-command command :output *verbose-out*)

    #+allegro
    ;; will this fail if command has embedded quotes - it seems to work
    (multiple-value-bind (stdout stderr exit-code)
        (excl.osi:command-output
         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
         #+mswindows command ; BEWARE!
         :input nil :whole nil
         #+mswindows :show-window #+mswindows :hide)
      (asdf-message "~{~&~a~%~}~%" stderr)
      (asdf-message "~{~&~a~%~}~%" stdout)
      exit-code)

    #+clisp
    ;; CLISP returns NIL for exit status zero.
    (if *verbose-out*
        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
                                    command))
               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
            (multiple-value-bind (retval out-lines)
                (unwind-protect
                     (parse-clisp-shell-output outstream)
                  (ignore-errors (close outstream)))
              (asdf-message "~{~&~a~%~}~%" out-lines)
              retval))
        ;; there will be no output, just grab up the exit status
        (or (ext:run-shell-command command :output nil :wait t) 0))

    #+clozure
    (nth-value 1
               (ccl:external-process-status
                (ccl:run-program
                 (cond
                   ((os-unix-p) "/bin/sh")
                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
                   (t (error "Unsupported OS")))
                 (if (os-unix-p) (list "-c" command) '())
                 :input nil :output *verbose-out* :wait t)))

    #+(or cmu scl)
    (ext:process-exit-code
     (ext:run-program
      "/bin/sh"
      (list "-c" command)
      :input nil :output *verbose-out*))

    #+cormanlisp
    (win32:system command)

    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    (ext:system command)

    #+gcl
    (lisp:system command)

    #+lispworks
    (apply 'system:call-system-showing-output command
           :show-cmd nil :prefix "" :output-stream *verbose-out*
           (when (os-unix-p) '(:shell-type "/bin/sh")))

    #+mcl
    (ccl::with-cstrs ((%command command)) (_system %command))

    #+mkcl
    ;; This has next to no chance of working on basic Windows!
    ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
    (multiple-value-bind (io process exit-code)
        (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
                                  (list "-c" command)
                                  :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
                                  #-windows '(:search nil))
      (declare (ignore io process))
      exit-code)

    #+sbcl
    (sb-ext:process-exit-code
     (apply 'sb-ext:run-program
            #+win32 "sh" #-win32 "/bin/sh"
            (list  "-c" command)
            :input nil :output *verbose-out*
            #+win32 '(:search t) #-win32 nil))

    #+xcl
    (ext:run-shell-command command)

    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))

#+clisp
(defun* parse-clisp-shell-output (stream)
  "Helper function for running shell commands under clisp.  Parses a specially-
crafted output string to recover the exit status of the shell command and a
list of lines of output."
  (loop :with status-prefix = "ASDF-EXIT-STATUS "
    :with prefix-length = (length status-prefix)
    :with exit-status = -1 :with lines = ()
    :for line = (read-line stream nil nil)
    :while line :do (push line lines) :finally
    (let* ((last (car lines))
           (status (and last (>= (length last) prefix-length)
                        (string-equal last status-prefix :end1 prefix-length)
                        (parse-integer last :start prefix-length :junk-allowed t))))
      (when status
        (setf exit-status status)
        (pop lines) (when (equal "" (car lines)) (pop lines)))
      (return (values exit-status (reverse lines))))))