find-system.lisp 16.4 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 #:system-out-of-date))
12 13
(in-package :asdf/find-system)

14 15 16 17 18 19 20 21
(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)))))

23 24 25 26 27 28 29
  (define-condition system-out-of-date (condition)
    ;; NB: not an error, not a warning, but a normal expected condition
    ((name :initarg :name :reader component-name))
    (:documentation "condition signaled when a system is detected as being out of date")
    (:report (lambda (c s)
               (format s "system ~A is out of date" (component-name c)))))

30 31 32 33

  ;;; Methods for find-system

  ;; Reject NIL as a system designator.
34 35 36 37
  (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.
39 40 41 42
  (defmethod find-system (name &optional (error-p t))
    (find-system (coerce-name name) error-p))

  (defun find-system-if-being-defined (name)
43 44 45 46 47 48 49
    ;; 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))))

52 53 54
  (defclass define-op (non-propagating-operation) ()
    (:documentation "An operation to record dependencies on loading a .asd file."))

55 56 57 58 59
  (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))))
60 61 62
      (if-let ((action (first (visiting-action-list *asdf-session*))))
        (let ((parent-operation (action-operation action))
              (parent-component (action-component action)))
63 64 65
          (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))
67 68 69 70
          (let ((action (cons operation component)))
            (unless (gethash action (definition-dependency-set parent-component))
              (push (cons operation component) (definition-dependency-list parent-component))
              (setf (gethash action (definition-dependency-set parent-component)) t)))))))

  (defmethod component-depends-on ((o define-op) (s system))
73 74
    `(;;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-dependency-list s) :collect (list o c))))
76 77 78

  (defmethod component-depends-on ((o operation) (s system))
    `(,@(when (and (not (typep o 'define-op))
                   (or (system-source-file s) (definition-dependency-list s)))
              `((define-op ,(primary-system-name s))))
81 82

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

86 87 88 89 90
  ;; 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)))

92 93
  (defmethod perform ((o define-op) (s system))
    (assert (equal (coerce-name s) (primary-system-name s)))
     (if-let ((pathname (first (input-files o s)))))
97 98 99 100 101 102 103 104 105 106 107
     (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)))))
108 109 110 111
         (((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~@:>~%")
                     (coerce-name s) pathname)
       ;; dependencies will depend on what's loaded via definition-dependency-list
116 117
       (unset-asdf-cache-entry `(component-depends-on ,o ,s)))
     (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132

  (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?
133 134 135
              (setf (component-operation-time operation system) nil
                    (definition-dependency-list system) nil
                    (definition-dependency-set system) (list-to-hash-set nil))
136 137 138 139 140 141 142
              (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)))))))))

144 145
  (defvar *old-asdf-systems* (make-hash-table :test 'equal))

146 147 148
  ;; (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.
149 150 151 152 153 154 155
  (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!
158 159 160 161
            (t ;; old version: bad
              (list (namestring pathname) version) *old-asdf-systems*
              #'(lambda ()
                 (let ((old-pathname (system-source-file (registered-system "asdf"))))
                   (warn "~@<~
164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
        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.~@:>~%"
185 186
                         old-version old-pathname version pathname))))
             nil))))) ;; only issue the warning the first time, but always return nil

188 189
  (defun locate-system (name)
    "Given a system NAME designator, try to locate where to load the system from.
190 191 192
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
193 194
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,
195 196 197
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,
199 200 201 202 203 204 205 206 207 208 209
      ;; 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))
210 211
                            (system-source-file found-system)
                            (system-source-file previous))
212 213 214 215
                        :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)
216 217
          (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;
222 223 224
  ;; 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))
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
     (with-asdf-session (:key `(find-system ,name)))
     (let* ((name-primary-p (primary-system-p name))
            (primary-system (unless name-primary-p (find-system (primary-system-name name) nil)))))
     (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
     (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))
           (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))
       (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.
                     (loop :with plan = (make-instance *plan-class*)
253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
                       :for action :in (definition-dependency-list previous)
                       :always (handler-bind
                                     (lambda (c) (declare (ignore c)) (return nil))))
                                 (action-up-to-date-p plan
                                                      (action-operation action)
                                                      (action-component action)))
                       (let ((o (make-operation 'define-op))
                             (s (if name-primary-p previous primary-system)))
                         (when s
                           (multiple-value-bind (stamp done-p)
                               (compute-action-stamp plan o s)
                             (return (and (stamp<= stamp (component-operation-time o s))
           (unless up-to-date-p
                 (signal 'system-out-of-date :name name)
               (continue () :report "continue"))
             (load-asd pathname :name name)))))
     ;; Try again after having loaded from disk if needed
     (or (registered-system name)
         (when error-p (error 'missing-component :requires name)))))
276 277 278 279 280 281 282 283 284

  ;; Resolved forward reference for asdf/system-registry.
  (defun mark-component-preloaded (component)
    "Mark a component as preloaded."
    (let ((component (find-component component nil :registered t)))
      ;; Recurse to children, so asdf/plan will hopefully be happy.
      (map () 'mark-component-preloaded (component-children component))
      ;; Mark the timestamps of the common lisp-action operations as 0.
      (let ((times (component-operation-times component)))
        (dolist (o `(,@(when (primary-system-p component) '(define-op))
286 287
                       prepare-op compile-op load-op))
          (setf (gethash (make-operation o) times) 0))))))