find-system.lisp 14.1 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Finding systems

(uiop/package:define-package :asdf/find-system
  (:recycle :asdf/find-system :asdf)
  (:use :uiop/common-lisp :uiop :asdf/upgrade
7 8
        :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action
        :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
   #:find-system #:locate-system #:load-asd #:define-op
   #:load-system-definition-error #:error-name #:error-pathname #:error-condition
13 14
(in-package :asdf/find-system)

15 16 17 18 19 20 21 22
(with-upgradability ()
  (define-condition load-system-definition-error (system-definition-error)
    ((name :initarg :name :reader error-name)
     (pathname :initarg :pathname :reader error-pathname)
     (condition :initarg :condition :reader error-condition))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
                       (error-name c) (error-pathname c) (error-condition c)))))

24 25 26 27

  ;;; Methods for find-system

  ;; Reject NIL as a system designator.
28 29 30 31
  (defmethod find-system ((name null) &optional (error-p t))
    (when error-p
      (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))

  ;; Default method for find-system: resolve the argument using COERCE-NAME.
33 34 35 36
  (defmethod find-system (name &optional (error-p t))
    (find-system (coerce-name name) error-p))

  (defun find-system-if-being-defined (name)
37 38 39 40 41 42 43
    ;; This function finds systems being defined *in the current ASDF session*, as embodied by
    ;; its session cache, even before they are fully defined and registered in *defined-systems*.
    ;; The purpose of this function is to prevent races between two files that might otherwise
    ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow.
    ;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
    ;; NB: this function depends on a corresponding side-effect in parse-defsystem;
    ;; the precise protocol between the two functions may change in the future (or not).
    (first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))

46 47 48
  (defclass define-op (non-propagating-operation) ()
    (:documentation "An operation to record dependencies on loading a .asd file."))

49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
  (defmethod record-dependency ((plan null) (operation t) (component t))
    (unless (or (typep operation 'define-op)
                (and (typep operation 'load-op)
                     (typep component 'system)
                     (equal "asdf" (coerce-name component))))
      (let* ((action (first (visiting-action-list *asdf-session*)))
             (parent-operation (car action))
             (parent-component (cdr action)))
        (when (and parent-operation parent-component)
          (unless (and (typep parent-operation 'define-op) (typep parent-component 'system))
            (error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~
- please use proper dependencies instead."
                   operation component action))
          (push action (definition-dependencies parent-component))))))

  (defmethod component-depends-on ((o define-op) (s system))
65 66 67 68 69 70 71 72
    `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
      ;; 2- We don't call-next-method to avoid other methods
      ,@(loop* :for (o . c) :in (definition-dependencies s) :collect (list o c))))

  (defmethod component-depends-on ((o operation) (s system))
    `(,@(when (and (not (typep o 'define-op))
                   (or (system-source-file s) (definition-dependencies s)))
              `((define-op ,(primary-system-name s))))
73 74

  (defmethod perform ((o operation) (c undefined-system))
76 77
    (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c)))

78 79 80 81 82
  ;; TODO: could this file be refactored so that locate-system is merely
  ;; the cache-priming call to input-files here?
  (defmethod input-files ((o define-op) (s system))
    (assert (equal (coerce-name s) (primary-system-name s)))
    (if-let ((asd (system-source-file s))) (list asd)))

84 85
  (defmethod perform ((o define-op) (s system))
    (assert (equal (coerce-name s) (primary-system-name s)))
     (if-let ((pathname (first (input-files o s)))))
89 90 91 92 93 94 95 96 97 98 99
     (let ((*print-readably* nil)
           ;; Note that our backward-compatible *readtable* is
           ;; a global readtable that gets globally side-effected. Ouch.
           ;; Same for the *print-pprint-dispatch* table.
           ;; We should do something about that for ASDF3 if possible, or else ASDF4.
           (*readtable* *readtable*)
           (*print-pprint-dispatch* *print-pprint-dispatch*)
           (*package* (find-package :asdf-user))
            ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
            (pathname-directory-pathname (physicalize-pathname pathname)))))
100 101 102 103
         (((and error (not missing-component))
           #'(lambda (condition)
               (error 'load-system-definition-error
                      :name (coerce-name s) :pathname pathname :condition condition))))
       (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
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
                     (coerce-name s) pathname)
       ;; dependencies will depend on what's loaded via definition-dependencies
       (unset-asdf-cache-entry `(component-depends-on ,o ,s))
       (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))))

  (defun load-asd (pathname &key name)
    "Load system definitions from PATHNAME.
NAME if supplied is the name of a system expected to be defined in that file.

Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
    (with-asdf-session ()
      ;; TODO: use OPERATE, so we consult the cache and only load once per session.
      (flet ((do-it (o c) (operate o c)))
        (let ((primary-name (primary-system-name (or name (pathname-name pathname))))
              (operation (make-operation 'define-op)))
          (if-let (system (registered-system primary-name))
              ;; We already determine this to be obsolete ---
              ;; or should we move some tests from find-system to check for up-to-date-ness here?
              (setf (component-operation-time operation system) nil)
              (do-it operation system))
            (let ((system (make-instance 'undefined-system
                                         :name primary-name :source-file pathname)))
              (register-system system)
              (unwind-protect (do-it operation system)
                (when (typep system 'undefined-system)
                  (clear-system system)))))))))

134 135
  (defvar *old-asdf-systems* (make-hash-table :test 'equal))

136 137 138
  ;; (Private) function to check that a system that was found isn't an asdf downgrade.
  ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version,
  ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF.
139 140 141 142 143 144 145
  (defun check-not-old-asdf-system (name pathname)
    (or (not (equal name "asdf"))
        (null pathname)
        (let* ((version-pathname (subpathname pathname "version.lisp-expr"))
               (version (and (probe-file* version-pathname :truename nil)
                             (read-file-form version-pathname)))
               (old-version (asdf-version)))
            ((version<= old-version version) t) ;; newer or same version: good!
148 149 150 151
            (t ;; old version: bad
              (list (namestring pathname) version) *old-asdf-systems*
              #'(lambda ()
                 (let ((old-pathname (system-source-file (registered-system "asdf"))))
                   (warn "~@<~
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
        You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
        or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
        ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
        Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
        and having an old version registered is a configuration error. ~
        ASDF will ignore this configured system rather than downgrade itself. ~
        In the future, you may want to either: ~
        (a) upgrade this configured ASDF to a newer version, ~
        (b) install a newer ASDF and register it in front of the former in your configuration, or ~
        (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
        Note that the older ASDF might be registered implicitly through configuration inherited ~
        from your system installation, in which case you might have to specify ~
        :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
        or other source-registry configuration file, environment variable or lisp parameter. ~
        Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
        that you might want to upgrade (if a recent enough version is available) ~
        or else remove altogether (since most implementations ship with a recent asdf); ~
        if you lack the system administration rights to upgrade or remove this package, ~
        then you might indeed want to either install and register a more recent version, ~
        or use :ignore-inherited-configuration to avoid registering the old one. ~
        Please consult ASDF documentation and/or experts.~@:>~%"
175 176
                         old-version old-pathname version pathname))))
             nil))))) ;; only issue the warning the first time, but always return nil

178 179
  (defun locate-system (name)
    "Given a system NAME designator, try to locate where to load the system from.
180 181 182
FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one.
Robert P. Goldman's avatar
Robert P. Goldman committed
183 184
FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
PATHNAME when not null is a path from which to load the system,
185 186 187
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
    (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
189 190 191 192 193 194 195 196 197 198 199
      ;; and keeping a negative cache was a bug (see lp#1335323), which required
      ;; explicit invalidation in clear-system and find-system (when unsucccessful).
      (let* ((name (coerce-name name))
             (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
             (previous (cdr in-memory))
             (previous (and (typep previous 'system) previous))
             (previous-time (car in-memory))
             (found (search-for-system-definition name))
             (found-system (and (typep found 'system) found))
             (pathname (ensure-pathname
                        (or (and (typep found '(or pathname string)) (pathname found))
200 201
                            (system-source-file found-system)
                            (system-source-file previous))
202 203 204 205
                        :want-absolute t :resolve-symlinks *resolve-symlinks*))
             (foundp (and (or found-system pathname previous) t)))
        (check-type found (or null pathname system))
        (unless (check-not-old-asdf-system name pathname)
206 207
          (check-type previous system) ;; asdf is preloaded, so there should be a previous one.
          (setf found-system nil pathname nil))
        (values foundp found-system pathname previous previous-time))))

  ;; Main method for find-system: first, make sure the computation is memoized in a session cache.
  ;; Unless the system is immutable, use locate-system to find the primary system;
212 213 214
  ;; reconcile the finding (if any) with any previous definition (in a previous session,
  ;; preloaded, with a previous configuration, or before filesystem changes), and
  ;; load a found .asd if appropriate. Finally, update registration table and return results.
  (defmethod find-system ((name string) &optional (error-p t))
    (with-asdf-session (:key `(find-system ,name))
217 218 219
      (let ((primary-name (primary-system-name name)))
        (unless (equal name primary-name)
          (find-system primary-name nil)))
      (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))
221 222 223
          (multiple-value-bind (foundp found-system pathname previous previous-time)
              (locate-system name)
            (assert (eq foundp (and (or found-system pathname previous) t)))
            (let ((previous-pathname (system-source-file previous))
225 226 227 228 229
                  (system (or previous found-system)))
              (when (and found-system (not previous))
                (register-system found-system))
              (when (and system pathname)
                (setf (system-source-file system) pathname))
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
              (if-let ((stamp (get-file-stamp pathname)))
                (let ((up-to-date-p
                       (and previous
                            (or (pathname-equal pathname previous-pathname)
                                (and pathname previous-pathname
                                      (physicalize-pathname pathname)
                                      (physicalize-pathname previous-pathname))))
                            (stamp<= stamp previous-time)
                            ;; TODO: check that all dependencies are up-to-date.
                            ;; This necessitates traversing them without triggering
                            ;; the adding of nodes to the plan.
                  (unless up-to-date-p
                    (load-asd pathname :name name)))))
            ;; Try again after having loaded from disk if needed
246 247 248
            (or (registered-system name)
                (when error-p (error 'missing-component :requires name))))))))