backward-interface.lisp 9.23 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces

4
(uiop/package:define-package :asdf/backward-interface
5
  (:recycle :asdf/backward-interface :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade
7
   :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
8
   :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
9 10
  (:export
   #:*asdf-verbose*
11
   #:operation-error #:compile-error #:compile-failed #:compile-warned
12
   #:error-component #:error-operation #:traverse
13 14 15
   #:component-load-dependencies
   #:enable-asdf-binary-locations-compatibility
   #:operation-forced
16
   #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
17
   #:component-property
18 19 20 21
   #:run-shell-command
   #:system-definition-pathname))
(in-package :asdf/backward-interface)

22
(with-upgradability ()
23 24 25 26
  ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
  ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
  ;; that do not involve ASDF actions.
  ;; TODO: find the offenders and stop them.
27 28 29 30 31
  (define-condition operation-error (error) ;; Bad, backward-compatible name
    ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
    ((component :reader error-component :initarg :component)
     (operation :reader error-operation :initarg :operation))
    (:report (lambda (c s)
32 33
               (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
                       (type-of c) (error-operation c) (error-component c)))))
34 35 36 37 38 39
  (define-condition compile-error (operation-error) ())
  (define-condition compile-failed (compile-error) ())
  (define-condition compile-warned (compile-error) ())

  (defun component-load-dependencies (component)
    ;; Old deprecated name for the same thing. Please update your software.
40
    (component-sideway-dependencies component))
41 42

  (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
43 44 45 46 47
  ;; swank.asd looks at where the operation was forced to actually reload swank.
  ;; But the only reason the action would be performed again is because it was forced;
  ;; so the check is redundant. More generally, if you have to do it when the operation was forced,
  ;; you should do it when not, and vice-versa, because it really shouldn't matter.
  ;; Thus, the backward-compatible thing to do is to always return T.
48 49
  (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))

50 51 52

  ;; These old interfaces from ASDF1 have never been very meaningful
  ;; but are still used in obscure places.
53 54
  (defgeneric operation-on-warnings (operation))
  (defgeneric operation-on-failure (operation))
55 56
  (defgeneric (setf operation-on-warnings) (x operation))
  (defgeneric (setf operation-on-failure) (x operation))
57
  (defmethod operation-on-warnings ((o operation))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
58
    *compile-file-warnings-behaviour*)
59
  (defmethod operation-on-failure ((o operation))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
60
    *compile-file-failure-behaviour*)
61
  (defmethod (setf operation-on-warnings) (x (o operation))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
62
    (setf *compile-file-warnings-behaviour* x))
63
  (defmethod (setf operation-on-failure) (x (o operation))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
64
    (setf *compile-file-failure-behaviour* x))
65 66 67 68 69 70

  (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.
71 72 73 74 75 76
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." ;;)
77 78
    (system-source-file x))

79 80 81

  ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
  ;; It was never officially exposed but some people still used it.
82 83 84 85 86 87 88 89 90 91 92
  (defgeneric* (traverse) (operation component &key &allow-other-keys)
    (:documentation
     "Generate and return a plan for performing OPERATION on COMPONENT.

The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."))
  (define-convenience-action-methods traverse (operation component &key))

  (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
    (plan-actions (apply 'make-plan plan-class o c keys))))
93 94 95


;;;; ASDF-Binary-Locations compatibility
96
;; This remains supported for legacy user, but not recommended for new users.
97
;; We suspect there are no more legacy users in 2016.
98 99 100 101 102 103 104
(with-upgradability ()
  (defun enable-asdf-binary-locations-compatibility
      (&key
       (centralize-lisp-binaries nil)
       (default-toplevel-directory
        (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
       (include-per-user-information nil)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
105
       (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
106 107 108
       (source-to-target-mappings nil)
       (file-types `(,(compile-file-type)
                     "build-report"
109 110
                     #+clasp (compile-file-type :output-type :object)
                     #+ecl (compile-file-type :type :object)
111 112 113
                     #+mkcl (compile-file-type :fasl-p nil)
                     #+clisp "lib" #+sbcl "cfasl"
                     #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
114
    #+(or clasp clisp ecl mkcl)
115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
    (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* ((patterns (if map-all-source-files (list *wild-file*)
                         (loop :for type :in file-types
                               :collect (make-pathname :type type :defaults *wild-file*))))
           (destination-directory
             (if centralize-lisp-binaries
                 `(,default-toplevel-directory
                   ,@(when include-per-user-information
                       (cdr (pathname-directory (user-homedir-pathname))))
                   :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))
         ,@(loop :for pattern :in patterns
                 :collect `((:root ,*wild-inferiors* ,pattern)
                            (,@destination-directory ,pattern)))
         (t t)
         :ignore-inherited-configuration))))

  (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
139
    (declare (ignore operation-class system args))
140 141
    (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.
142 143 144 145 146 147
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;
148
call that function where you would otherwise have loaded and configured A-B-L."))))
149 150


151 152
;;; run-shell-command
;; WARNING! The function below is not just deprecated but also dysfunctional.
153
;; Please use asdf/run-program:run-program instead.
154 155 156
(with-upgradability ()
  (defun run-shell-command (control-string &rest args)
    "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
157
synchronously execute the result using a Bourne-compatible shell, with
158 159 160 161
output to *VERBOSE-OUT*.  Returns the shell's exit code.

PLEASE DO NOT USE.
Deprecated function, for backward-compatibility only.
162
Please use UIOP:RUN-PROGRAM instead."
163 164
    (let ((command (apply 'format nil control-string args)))
      (asdf-message "; $ ~A~%" command)
165
      (let ((exit-code
166 167 168
              (ignore-errors
               (nth-value 2 (run-program command :force-shell t :ignore-error-status t
                                                 :output *verbose-out*)))))
169 170 171
        (typecase exit-code
          ((integer 0 255) exit-code)
          (t 255))))))
172

173 174
(with-upgradability ()
  (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
175 176

;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
177 178 179 180 181 182 183 184 185 186 187 188 189 190
(with-upgradability ()
  (defgeneric component-property (component property))
  (defgeneric (setf component-property) (new-value component property))

  (defmethod component-property ((c component) property)
    (cdr (assoc property (slot-value c 'properties) :test #'equal)))

  (defmethod (setf component-property) (new-value (c component) property)
    (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
      (if a
          (setf (cdr a) new-value)
          (setf (slot-value c 'properties)
                (acons property new-value (slot-value c 'properties)))))
    new-value))