Skip to content
Snippets Groups Projects
asdf.lisp 104 KiB
Newer Older
;;; This is asdf: Another System Definition Facility.
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; Note first that the canonical source for asdf is presently
;;; <URL:http://common-lisp.net/project/asdf/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
;;; bugs.  There are usually two "supported" revisions - the git HEAD
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'

;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from
;;;  http://www.opensource.org/licenses/mit-license.html on or about
;;;  Monday; July 13, 2009)
;;;
;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;
;;; -- LICENSE END
;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it.  Hence, all in one file.
Daniel Barlow's avatar
Daniel Barlow committed

#+xcvb (module ())

(declaim (optimize (speed 1) (debug 3) (safety 3)))

;;;; -------------------------------------------------------------------------
;;;; Cleanups in case of hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; These must come *before* the defpackage form.
;;;; See more at the end of the file.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((asdf (find-package :asdf)))
    (when asdf
      (let ((sym (find-symbol "*ASDF-REVISION*" asdf)))
        (when sym
          (unintern sym asdf))))))
Daniel Barlow's avatar
Daniel Barlow committed
(defpackage #:asdf
  (:documentation "Another System Definition Facility")
Daniel Barlow's avatar
Daniel Barlow committed
  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
           #:system-definition-pathname #:find-component ; miscellaneous
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:compile-system #:load-system #:test-system
           #:compile-op #:load-op #:load-source-op
           #:test-op
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:operation                 ; operations
           #:feature                 ; sort-of operation
           #:version                 ; metaphorically sort-of an operation
           #:input-files #:output-files #:perform ; operation methods
           #:operation-done-p #:explain

           #:component #:source-file
           #:c-source-file #:cl-source-file #:java-source-file
           #:static-file
           #:doc-file
           #:html-file
           #:text-file
           #:source-file-type
           #:module                     ; components
           #:system
           #:unix-dso

           #:module-components          ; component accessors
           #:component-pathname
           #:component-relative-pathname
           #:component-name
           #:component-version
           #:component-parent
           #:component-property
           #:component-system

           #:component-depends-on

           #:system-description
           #:system-long-description
           #:system-author
           #:system-maintainer
           #:system-license
           #:system-licence
           #:system-source-file
           #:system-relative-pathname
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:map-systems

           #:operation-on-warnings
           #:operation-on-failure

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                        ;#:*component-parent-pathname*
           #:*system-definition-search-functions*
           #:*central-registry*         ; variables
           #:*compile-file-warnings-behaviour*
           #:*compile-file-failure-behaviour*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:*resolve-symlinks*
           #:operation-error #:compile-failed #:compile-warned #:compile-error
           #:error-name
           #:error-pathname
           #:missing-definition
           #:error-component #:error-operation
           #:system-definition-error
           #:missing-component
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:missing-component-of-version
           #:missing-dependency
           #:circular-dependency        ; errors
           #:duplicate-names

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:try-recompiling
           #:retry
           #:accept                     ; restarts
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:coerce-entry-to-directory
           #:remove-entry-from-registry

           #:standard-asdf-method-combination
           #:around                     ; protocol assistants
           #:initialize-output-translations
           #:clear-output-translations
           #:ensure-output-translations
           #:apply-output-translations

           #:initialize-source-registry
           #:clear-source-registry
           #:ensure-source-registry
           #:process-source-registry)
  (:intern #:coerce-name
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           #:system-registered-p
           #:asdf-message
           #:resolve-symlinks
           #:pathname-sans-name+type)
Daniel Barlow's avatar
Daniel Barlow committed
  (:use :cl))
(defpackage #:asdf-extensions
  (:use #:common-lisp #:asdf)
  (:import-from #:asdf
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                #:coerce-name
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                #:system-registered-p
                #:asdf-message
                #:resolve-symlinks
                #:pathname-sans-name+type))
(error "The author of this file habitually uses #+nil to comment out ~
        forms. But don't worry, it was unlikely to work in the New ~
        Implementation of Lisp anyway")
Daniel Barlow's avatar
Daniel Barlow committed
(in-package #:asdf)

;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
  ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
  (subseq "VERSION:1.602" (1+ (length "VERSION"))))
(defvar *resolve-symlinks* t
  "Determine whether or not ASDF resolves symlinks when defining systems.

Defaults to `t`.")

(defvar *compile-file-warnings-behaviour* :warn)
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
Daniel Barlow's avatar
 
Daniel Barlow committed

(defparameter +asdf-methods+
  '(perform explain output-files operation-done-p))

;;;; -------------------------------------------------------------------------
;;;; Cleanups before hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; * fmakunbound functions that once (in previous version of ASDF)
;;;;   were simple DEFUNs but now are generic functions.
;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
;;;;   for each of the classes we define that has changed incompatibly.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (and (fboundp 'system-source-file)
             (not (typep (fdefinition 'system-source-file) 'generic-function)))
    (fmakunbound 'system-source-file))
  #+ecl
  (when (find-class 'compile-op nil)
    (defmethod update-instance-for-redefined-class :after
        ((c compile-op) added deleted plist &key)
      (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
      (let ((system-p (getf plist 'system-p)))
        (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))

;;;; -------------------------------------------------------------------------
;;;; CLOS magic for asdf:around methods

(define-method-combination standard-asdf-method-combination ()
  ((around-asdf (around))
   (around (:around))
   (before (:before))
   (primary () :required t)
   (after (:after)))
  (flet ((call-methods (methods)
           (mapcar #'(lambda (method)
                       `(call-method ,method))
                   methods)))
    (let* ((form (if (or before after (rest primary))
                     `(multiple-value-prog1
                          (progn ,@(call-methods before)
                                 (call-method ,(first primary)
                                              ,(rest primary)))
                        ,@(call-methods (reverse after)))
                     `(call-method ,(first primary))))
           (standard-form (if around
                              `(call-method ,(first around)
                                            (,@(rest around)
                                               (make-method ,form)))
                              form)))
      (if around-asdf
          `(call-method ,(first around-asdf)
                        (,@(rest around-asdf) (make-method ,standard-form)))
          standard-form))))

(setf (documentation 'standard-asdf-method-combination
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                     'method-combination)
      "This method combination is based on the standard method combination,
but defines a new method-qualifier, `asdf:around`.  `asdf:around`
methods will be run *around* any `:around` methods, so that the core
protocol may employ around methods and those around methods will not
be overridden by around methods added by a system developer.")

;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.

(defgeneric perform (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric explain (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric output-files (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric input-files (operation component)
  (:method-combination standard-asdf-method-combination))

(defgeneric system-source-file (system)
  (:documentation "Return the source file in which system is defined."))

(defgeneric component-system (component)
  (:documentation "Find the top-level system containing COMPONENT"))

(defgeneric component-pathname (component)
  (:documentation "Extracts the pathname applicable for a particular component."))

(defgeneric component-relative-pathname (component)
  (:documentation "Extracts the relative pathname applicable for a particular component."))

(defgeneric component-property (component property))

(defgeneric (setf component-property) (new-value component property))

(defgeneric version-satisfies (component version))

(defgeneric find-component (module name &optional version)
  (:documentation "Finds the component with name NAME present in the
MODULE module; if MODULE is nil, then the component is assumed to be a
system."))

(defgeneric source-file-type (component system))

(defgeneric operation-ancestor (operation)
  (:documentation
   "Recursively chase the operation's parent pointer until we get to
the head of the tree"))

(defgeneric component-visited-p (operation component))

(defgeneric visit-component (operation component data))

(defgeneric (setf visiting-component) (new-value operation component))

(defgeneric component-visiting-p (operation component))

(defgeneric component-depends-on (operation component)
  (:documentation
   "Returns a list of dependencies needed by the component to perform
    the operation.  A dependency has one of the following forms:

      (<operation> <component>*), where <operation> is a class
        designator and each <component> is a component
        designator, which means that the component depends on
        <operation> having been performed on each <component>; or

      (FEATURE <feature>), which means that the component depends
        on <feature>'s presence in *FEATURES*.

    Methods specialized on subclasses of existing component types
    should usually append the results of CALL-NEXT-METHOD to the
    list."))

(defgeneric component-self-dependencies (operation component))

Gary King's avatar
Gary King committed
(defgeneric traverse (operation component)
  (:documentation
Gary King's avatar
Gary King committed
"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
Gary King's avatar
Gary King committed
processed in order by `operate`."))
(defgeneric output-files-using-mappings (source possible-paths path-mappings)
  (:documentation
"Use the variable \\*source-to-target-mappings\\* to find
an output path for the source. The algorithm transforms each
entry in possible-paths as follows: If there is a mapping
whose source starts with the path of possible-path, then
replace possible-path with a pathname that starts with the
target of the mapping and continues with the rest of
possible-path. If no such mapping is found, then use the
default mapping.

If \\*centralize-lisp-binaries\\* is false, then the default
mapping is to place the output in a subdirectory of the
source. The subdirectory is named using the Lisp
implementation \(see
implementation-specific-directory-name\). If
\\*centralize-lisp-binaries\\* is true, then the default
mapping is to place the output in subdirectories of
\\*default-toplevel-directory\\* where the subdirectory
structure will mirror that of the source."))

;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

(defun pathname-sans-name+type (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME and TYPE components" ;;; what about VERSION???
  (make-pathname :name nil :type nil :defaults pathname))
(define-modify-macro appendf (&rest args)
  append "Append onto list")
Daniel Barlow's avatar
 
Daniel Barlow committed

(defun asdf-message (format-string &rest format-args)
  (declare (dynamic-extent format-args))
  (apply #'format *verbose-out* format-string format-args))

;;; with apologies to christophe rhodes ...
(defun split (string &optional max (ws '(#\Space #\Tab)))
  (flet ((is-ws (char) (find char ws)))
    (nreverse
     (let ((list nil) (start 0) (words 0) end)
       (loop
         (when (and max (>= words (1- max)))
           (return (cons (subseq string start) list)))
         (setf end (position-if #'is-ws string :start start))
         (push (subseq string start end) list)
         (incf words)
         (unless end (return list))
         (setf start (1+ end)))))))

(defun split-path-string (s &optional force-directory)
  (check-type s string)
  (let* ((components (split s nil "/"))
         (last-comp (car (last components))))
    (multiple-value-bind (relative components)
        (if (equal (first components) "")
          (values :absolute (cdr components))
          (values :relative components))
      (cond
        ((equal last-comp "")
         (values relative (butlast components) nil))
        (force-directory
         (values relative components nil))
        (t
         (values relative (butlast components) last-comp))))))
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

(defun remove-keyword (key args)
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))

(defun resolve-symlinks (path)
  #-allegro (truename path)
  #+allegro (excl:pathname-resolve-symbolic-links path))

(defun getenv (x)
  #+sbcl
  (sb-ext:posix-getenv x)
  #+clozure
  (ccl::getenv x)
  #+clisp
  (ext:getenv x)
  #+cmu
  (cdr (assoc (intern x :keyword) ext:*environment-list*))
  #+lispworks
  (lispworks:environment-variable x)
  #+allegro
  (sys:getenv x)
  #+gcl
  (system:getenv x)
  #+ecl
  (si:getenv x))

(defun ensure-directory-pathname (pathspec)
  "Converts the non-wild pathname designator PATHSPEC to directory form."
  (cond
   ((stringp pathspec)
    (pathname (concatenate 'string pathspec "/")))
   ((not (pathnamep pathspec))
    (error "Invalid pathname designator ~S" pathspec))
   ((wild-pathname-p pathspec)
    (error "Can't reliably convert wild pathnames."))
   ((directory-pathname-p pathspec)
    pathspec)
   (t
    (make-pathname :directory (append (or (pathname-directory pathspec)
                                          (list :relative))
                                      (list (file-namestring pathspec)))
                   :name nil :type nil :version nil
                   :defaults pathspec))))
(defun absolute-pathname-p (pathspec)
  (eq :absolute (car (pathname-directory (pathname pathspec)))))

(defun length=n-p (x n) ;is it that (= (length x) n) ?
  (check-type n (integer 0 *))
  (loop
    :for l = x :then (cdr l)
    :for i :downfrom n :do
    (cond
      ((zerop i) (return (null l)))
      ((not (consp l)) (return nil)))))

(defun ends-with (s suffix)
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))
(defun make-collector ()
  (let ((acc ()))
    (values (lambda (x) (push x acc))
            (lambda () (reverse acc)))))

(defun read-file-forms (file)
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

#-windows
(progn
#+clisp (defun get-uid () (linux:getuid))
#+sbcl (defun get-uid () (sb-unix:unix-getuid))
#+cmu (defun get-uid () (unix:unix-getuid))
#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
#+allegro (defun get-uid () (excl.osi:getuid))
#-(or cmu sbcl clisp allegro ecl)
(defun get-uid ()
  (let ((uid-string
         (with-output-to-string (asdf::*VERBOSE-OUT*)
           (asdf:run-shell-command "id -ur"))))
    (with-input-from-string (stream uid-string)
      (read-line stream)
      (handler-case (parse-integer (read-line stream))
        (error () (error "Unable to find out user ID")))))))

(defun truenamize (p)
  "Resolve as much of a pathname as possible"
  (block :t
    (setf p (translate-logical-pathname (merge-pathnames p)))
    (ignore-errors (return-from :t (truename p)))
    (let ((host (pathname-host p))
          (device (pathname-device p))
          (directory (pathname-directory p)))
      (when (or (atom directory) (not (eq :absolute (car directory))))
        (return-from :t p))
      (let ((sofar (ignore-errors
                     (truename (make-pathname :host host :device device
                                              :directory '(:absolute))))))
        (unless sofar (return-from :t p))
        (loop :for component :in (cdr directory)
          :for rest :on (cdr directory)
          :for more = (ignore-errors
                        (truename
                         (merge-pathnames
                          (make-pathname :directory `(:relative ,component))
                          sofar))) :do
          (if more
              (setf sofar more)
              (return-from :t
                (merge-pathnames
                 (make-pathname :host nil :device nil
                                :directory `(:relative ,@rest)
                                :defaults p)
                 sofar)))
          :finally
          (return-from :t
            (merge-pathnames
             (make-pathname :host nil :device nil
                            :directory nil
                            :defaults p)
             sofar)))))))

;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
Daniel Barlow's avatar
Daniel Barlow committed

(define-condition system-definition-error (error) ()
  ;; [this use of :report should be redundant, but unfortunately it's not.
  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
  ;; over print-object; this is always conditions::%print-condition for
  ;; condition objects, which in turn does inheritance of :report options at
  ;; run-time.  fortunately, inheritance means we only need this kludge here in
  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
  #+cmu (:report print-object))

Daniel Barlow's avatar
Daniel Barlow committed
(define-condition formatted-system-definition-error (system-definition-error)
  ((format-control :initarg :format-control :reader format-control)
   (format-arguments :initarg :format-arguments :reader format-arguments))
  (:report (lambda (c s)
             (apply #'format s (format-control c) (format-arguments c)))))
(define-condition missing-definition (system-definition-error)
  ((name :initarg :name :reader error-name)
   (pathname :initarg :pathname :reader error-pathname))
  (:report (lambda (c s)
             (format s "~@<Definition search function returned a wrong pathname ~A ~
                           in search of a definition for system ~A.~@:>"
                     (error-pathname c) (error-name c)))))

Daniel Barlow's avatar
Daniel Barlow committed
(define-condition circular-dependency (system-definition-error)
  ((components :initarg :components :reader circular-dependency-components)))
(define-condition duplicate-names (system-definition-error)
  ((name :initarg :name :reader duplicate-names-name)))

(define-condition missing-component (system-definition-error)
  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
   (parent :initform nil :reader missing-parent :initarg :parent)))

(define-condition missing-component-of-version (missing-component)
  ((version :initform nil :reader missing-version :initarg :version)))

(define-condition missing-dependency (missing-component)
  ((required-by :initarg :required-by :reader missing-required-by)))

(define-condition missing-dependency-of-version (missing-dependency
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                                 missing-component-of-version)
Daniel Barlow's avatar
Daniel Barlow committed
(define-condition operation-error (error)
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
             (format s "~@<erred while invoking ~A on ~A~@:>"
                     (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
Daniel Barlow's avatar
Daniel Barlow committed

(defclass component ()
  ((name :accessor component-name :initarg :name :documentation
         "Component name: designator for a string composed of portable pathname characters")
Daniel Barlow's avatar
Daniel Barlow committed
   (version :accessor component-version :initarg :version)
   (in-order-to :initform nil :initarg :in-order-to
                :accessor component-in-order-to)
   ;; XXX crap name
   (do-first :initform nil :initarg :do-first
             :accessor component-do-first)
   ;; methods defined using the "inline" style inside a defsystem form:
   ;; need to store them somewhere so we can delete them when the system
   ;; is re-evaluated
   (inline-methods :accessor component-inline-methods :initform nil)
Daniel Barlow's avatar
Daniel Barlow committed
   (parent :initarg :parent :initform nil :reader component-parent)
Daniel Barlow's avatar
Daniel Barlow committed
   ;; no direct accessor for pathname, we do this as a method to allow
   ;; it to default in funky ways if not supplied
Daniel Barlow's avatar
 
Daniel Barlow committed
   (relative-pathname :initarg :pathname)
   (operation-times :initform (make-hash-table)
                    :accessor component-operation-times)
Daniel Barlow's avatar
 
Daniel Barlow committed
   ;; XXX we should provide some atomic interface for updating the
   ;; component properties
   (properties :accessor component-properties :initarg :properties
               :initform nil)))
Daniel Barlow's avatar
 
Daniel Barlow committed

Daniel Barlow's avatar
 
Daniel Barlow committed
;;;; methods: conditions

(defmethod print-object ((c missing-dependency) s)
  (format s "~@<~A, required by ~A~@:>"
          (call-next-method c nil) (missing-required-by c)))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defun sysdef-error (format &rest arguments)
  (error 'formatted-system-definition-error :format-control
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         format :format-arguments arguments))
Daniel Barlow's avatar
Daniel Barlow committed

Daniel Barlow's avatar
 
Daniel Barlow committed
;;;; methods: components

(defmethod print-object ((c missing-component) s)
   (format s "~@<component ~S not found~
          (missing-requires c)
          (when (missing-parent c)
            (component-name (missing-parent c)))))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defmethod print-object ((c missing-component-of-version) s)
  (format s "~@<component ~S does not match version ~A~
              ~@[ in ~A~]~@:>"
           (missing-requires c)
           (missing-version c)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           (when (missing-parent c)
             (component-name (missing-parent c)))))
Daniel Barlow's avatar
Daniel Barlow committed
(defmethod component-system ((component component))
  (aif (component-parent component)
       (component-system it)
       component))

(defmethod print-object ((c component) stream)
Daniel Barlow's avatar
Daniel Barlow committed
  (print-unreadable-object (c stream :type t :identity t)
Daniel Barlow's avatar
Daniel Barlow committed
    (ignore-errors
      (prin1 (component-name c) stream))))
Daniel Barlow's avatar
Daniel Barlow committed

(defclass module (component)
Daniel Barlow's avatar
 
Daniel Barlow committed
  ((components :initform nil :accessor module-components :initarg :components)
   ;; what to do if we can't satisfy a dependency of one of this module's
   ;; components.  This allows a limited form of conditional processing
   (if-component-dep-fails :initform :fail
                           :accessor module-if-component-dep-fails
                           :initarg :if-component-dep-fails)
Daniel Barlow's avatar
Daniel Barlow committed
   (default-component-class :accessor module-default-component-class
     :initform 'cl-source-file :initarg :default-component-class)))

Daniel Barlow's avatar
 
Daniel Barlow committed
(defun component-parent-pathname (component)
  (aif (component-parent component)
       (component-pathname it)
       (truename *default-pathname-defaults*)))
Daniel Barlow's avatar
 
Daniel Barlow committed

Daniel Barlow's avatar
Daniel Barlow committed
(defmethod component-relative-pathname ((component module))
Daniel Barlow's avatar
Daniel Barlow committed
  (or (slot-value component 'relative-pathname)
      (multiple-value-bind (relative path)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
          (split-path-string (component-name component) t)
        (make-pathname
         :directory `(,relative ,@path)
         :host (pathname-host (component-parent-pathname component))))))
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod component-pathname ((component component))
  (merge-pathnames (component-relative-pathname component)
                   (component-parent-pathname component)))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defmethod component-property ((c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
  (cdr (assoc property (slot-value c 'properties) :test #'equal)))

(defmethod (setf component-property) (new-value (c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
        (setf (cdr a) new-value)
        (setf (slot-value c 'properties)
              (acons property new-value (slot-value c 'properties))))))
Daniel Barlow's avatar
 
Daniel Barlow committed
(defclass system (module)
  ((description :accessor system-description :initarg :description)
Daniel Barlow's avatar
Daniel Barlow committed
   (long-description
    :accessor system-long-description :initarg :long-description)
Daniel Barlow's avatar
 
Daniel Barlow committed
   (author :accessor system-author :initarg :author)
   (maintainer :accessor system-maintainer :initarg :maintainer)
   (licence :accessor system-licence :initarg :licence
            :accessor system-license :initarg :license)
   (source-file :reader system-source-file :initarg :source-file
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                :writer %set-system-source-file)))
Daniel Barlow's avatar
 
Daniel Barlow committed

;;;; -------------------------------------------------------------------------
;;;; version-satisfies
Daniel Barlow's avatar
 
Daniel Barlow committed

(defmethod version-satisfies ((c component) version)
  (unless (and version (slot-boundp c 'version))
    (return-from version-satisfies t))
  (let ((x (mapcar #'parse-integer
                   (split (component-version c) nil '(#\.))))
        (y (mapcar #'parse-integer
                   (split version nil '(#\.)))))
Daniel Barlow's avatar
 
Daniel Barlow committed
    (labels ((bigger (x y)
               (cond ((not y) t)
                     ((not x) nil)
                     ((> (car x) (car y)) t)
                     ((= (car x) (car y))
                      (bigger (cdr x) (cdr y))))))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (and (= (car x) (car y))
           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
Daniel Barlow's avatar
 
Daniel Barlow committed

;;;; -------------------------------------------------------------------------
;;;; Finding systems
Daniel Barlow's avatar
 
Daniel Barlow committed

(defun make-defined-systems-table ()
  (make-hash-table :test 'equal))

(defvar *defined-systems* (make-defined-systems-table)
  "This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first
element of which is a universal-time indicating when the
system definition was last updated, and the second element
of which is a system object.")
Daniel Barlow's avatar
 
Daniel Barlow committed
(defun coerce-name (name)
  (typecase name
    (component (component-name name))
    (symbol (string-downcase (symbol-name name)))
    (string name)
    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defun system-registered-p (name)
  (gethash (coerce-name name) *defined-systems*))

Gary King's avatar
Gary King committed
(defun map-systems (fn)
  "Apply `fn` to each defined system.

`fn` should be a function of one argument. It will be
called with an object of type asdf:system."
  (maphash (lambda (_ datum)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
             (declare (ignore _))
             (destructuring-bind (_ . def) datum
               (declare (ignore _))
               (funcall fn def)))
           *defined-systems*))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-

(defvar *system-definition-search-functions*
(defun system-definition-pathname (system)
  (let ((system-name (coerce-name system)))
    (or
     (some (lambda (x) (funcall x system-name))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           *system-definition-search-functions*)
     (let ((system-pair (system-registered-p system-name)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
            (system-source-file (cdr system-pair)))))))
  `((directory-namestring *default-pathname-defaults*))
"A list of 'system directory designators' ASDF uses to find systems.

A 'system directory designator' is a pathname or a function
which evaluates to a pathname. For example:

    (setf asdf:*central-registry*
          (list '*default-pathname-defaults*
                #p\"/home/me/cl/systems/\"
                #p\"/usr/share/common-lisp/systems/\"))
")
(defun directory-pathname-p (pathname)
  "Does `pathname` represent a directory?

A directory-pathname is a pathname _without_ a filename. The three
ways that the filename components can be missing are for it to be `nil`,
`:unspecific` or the empty string.

Note that this does _not_ check to see that `pathname` points to an
actually-existing directory."
  (flet ((check-one (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           (not (null (member x '(nil :unspecific "")
                              :test 'equal)))))
    (and (check-one (pathname-name pathname))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         (check-one (pathname-type pathname)))))
(defun sysdef-central-registry-search (system)
  (let ((name (coerce-name system))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (to-remove nil)
        (to-replace nil))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           (dolist (dir *central-registry*)
             (let ((defaults (eval dir)))
               (when defaults
                 (cond ((directory-pathname-p defaults)
                        (let ((file (and defaults
                                         (make-pathname
                                          :defaults defaults :version :newest
                                          :name name :type "asd" :case :local)))
                               #+(and (or win32 windows) (not :clisp))
                               (shortcut (make-pathname
                                          :defaults defaults :version :newest
                                          :name name :type "asd.lnk" :case :local)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                          (if (and file (probe-file file))
                              (return file))
                          #+(and (or win32 windows) (not :clisp))
                          (when (probe-file shortcut)
                            (let ((target (parse-windows-shortcut shortcut)))
                              (when target
                                (return (pathname target)))))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                       (t
                        (restart-case
                            (let* ((*print-circle* nil)
                                   (message
                                    (format nil
                                            "~@<While searching for system `~a`: `~a` evaluated ~
to `~a` which is not a directory.~@:>"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                            system dir defaults)))
                              (error message))
                          (remove-entry-from-registry ()
                            :report "Remove entry from *central-registry* and continue"
                            (push dir to-remove))
                          (coerce-entry-to-directory ()
                            :report (lambda (s)
                                      (format s "Coerce entry to ~a, replace ~a and continue."
                                              (ensure-directory-pathname defaults) dir))
                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
        ;; cleanup
        (dolist (dir to-remove)
          (setf *central-registry* (remove dir *central-registry*)))
        (dolist (pair to-replace)
          (let* ((current (car pair))
                 (new (cdr pair))
                 (position (position current *central-registry*)))
            (setf *central-registry*
                  (append (subseq *central-registry* 0 position)
                          (list new)
                          (subseq *central-registry* (1+ position))))))))))
Christophe Rhodes's avatar
Christophe Rhodes committed
(defun make-temporary-package ()
  (flet ((try (counter)
           (ignore-errors
             (make-package (format nil "~a~D" 'asdf counter)
                           :use '(:cl :asdf)))))
Christophe Rhodes's avatar
Christophe Rhodes committed
    (do* ((counter 0 (+ counter 1))
          (package (try counter) (try counter)))
         (package package))))
(defun safe-file-write-date (pathname)
           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
           ;; user or some other agent has deleted an input file.  If
           ;; that's the case, well, that's not good, but as long as
           ;; the operation is otherwise considered to be done we
           ;; could continue and survive.
  (or (file-write-date pathname)
      (progn
        (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
              pathname)
        0)))
Daniel Barlow's avatar
 
Daniel Barlow committed
(defun find-system (name &optional (error-p t))
  (let* ((name (coerce-name name))
         (in-memory (system-registered-p name))
         (on-disk (system-definition-pathname name)))
Daniel Barlow's avatar
 
Daniel Barlow committed
    (when (and on-disk
               (or (not in-memory)
                   (< (car in-memory) (safe-file-write-date on-disk))))
Christophe Rhodes's avatar
Christophe Rhodes committed
      (let ((package (make-temporary-package)))
        (unwind-protect
             (with-open-file (asd on-disk :if-does-not-exist nil)
               (if asd
                   (let ((*package* package))
                     (asdf-message
                      "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                      ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                      ;; ON-DISK), but CMUCL barfs on that.
                      on-disk
                      *package*)
                   (error 'missing-definition :name name :pathname on-disk)))
Christophe Rhodes's avatar
Christophe Rhodes committed
          (delete-package package))))
    (let ((in-memory (system-registered-p name)))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (if in-memory
          (progn (if on-disk (setf (car in-memory)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                   (safe-file-write-date on-disk)))
                 (cdr in-memory))
          (if error-p (error 'missing-component :requires name))))))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defun register-system (name system)
  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
  (setf (gethash (coerce-name name) *defined-systems*)
        (cons (get-universal-time) system)))
Daniel Barlow's avatar
 
Daniel Barlow committed

;;;; -------------------------------------------------------------------------
;;;; Finding components
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod find-component ((module module) name &optional version)
Daniel Barlow's avatar
Daniel Barlow committed
  (if (slot-boundp module 'components)
      (let ((m (find name (module-components module)
                     :test #'equal :key #'component-name)))
        (if (and m (version-satisfies m version)) m))))

Daniel Barlow's avatar
Daniel Barlow committed

;;; a component with no parent is a system
(defmethod find-component ((module (eql nil)) name &optional version)
  (declare (ignorable module))
Daniel Barlow's avatar
 
Daniel Barlow committed
  (let ((m (find-system name nil)))
    (if (and m (version-satisfies m version)) m)))
Daniel Barlow's avatar
Daniel Barlow committed

Daniel Barlow's avatar
 
Daniel Barlow committed
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
(defclass source-file (component) ())

(defclass cl-source-file (source-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
Daniel Barlow's avatar
Daniel Barlow committed

Daniel Barlow's avatar
Daniel Barlow committed
(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
(defmethod source-file-type ((c c-source-file) (s module)) "c")
(defmethod source-file-type ((c java-source-file) (s module)) "java")
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod source-file-type ((c html-file) (s module)) "html")
(defmethod source-file-type ((c static-file) (s module)) nil)

(defun merge-component-relative-pathname (pathname name type)
  (multiple-value-bind (relative path filename)
      (split-path-string name)
  (merge-pathnames
   (or pathname (make-pathname :directory `(,relative ,@path)))
   (if type
       (make-pathname :name filename :type type)
       filename))))

(defmethod component-relative-pathname ((component source-file))
  (merge-component-relative-pathname
   (slot-value component 'relative-pathname)
   (component-name component)
   (source-file-type component (component-system component))))
;;;; -------------------------------------------------------------------------
;;;; Operations
Daniel Barlow's avatar
Daniel Barlow committed

;;; one of these is instantiated whenever #'operate is called
Daniel Barlow's avatar
Daniel Barlow committed

(defclass operation ()
  ((forced :initform nil :initarg :force :accessor operation-forced)
   (original-initargs :initform nil :initarg :original-initargs
                      :accessor operation-original-initargs)
   (visited-nodes :initform nil :accessor operation-visited-nodes)
   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
   (parent :initform nil :initarg :parent :accessor operation-parent)))

(defmethod print-object ((o operation) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (ignore-errors
      (prin1 (operation-original-initargs o) stream))))

(defmethod shared-initialize :after ((operation operation) slot-names
                                     &key force
                                     &allow-other-keys)
  (declare (ignorable operation slot-names force))
  ;; empty method to disable initarg validity checking
  )
Daniel Barlow's avatar
Daniel Barlow committed

(defun node-for (o c)
  (cons (class-name (class-of o)) c))

(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)