Changeset 14487


Ignore:
Timestamp:
04/30/13 06:11:32 (10 years ago)
Author:
Mark Evenson
Message:

Update to asdf-2.33.7 release candidate for ASDF3.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14461 r14487  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.33: Another System Definition Facility.
     2;;; This is ASDF 2.33.7: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
    … …  
    14581458    (etypecase x
    14591459      (symbol (typep condition x))
    1460       ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
     1460      ((simple-vector 2)
     1461       (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
    14611462      (function (funcall x condition))
    14621463      (string (and (typep condition 'simple-condition)
    … …  
    30613062   #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
    30623063   #:with-output #:output-string #:with-input
    3063    #:with-input-file #:call-with-input-file
     3064   #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
    30643065   #:finish-outputs #:format! #:safe-format!
    30653066   #:copy-stream-to-stream #:concatenate-files #:copy-file
    … …  
    32353236      (funcall thunk s)))
    32363237
    3237   (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
    3238     (declare (ignore element-type external-format))
    3239     `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
    3240 
     3238  (defmacro with-input-file ((var pathname &rest keys
     3239                              &key element-type external-format if-does-not-exist)
     3240                             &body body)
     3241    (declare (ignore element-type external-format if-does-not-exist))
     3242    `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
     3243
     3244  (defun call-with-output-file (pathname thunk
     3245                                &key
     3246                                  (element-type *default-stream-element-type*)
     3247                                  (external-format *utf-8-external-format*)
     3248                                  (if-exists :error)
     3249                                  (if-does-not-exist :create))
     3250    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
     3251Other keys are accepted but discarded."
     3252    #+gcl2.6 (declare (ignore external-format))
     3253    (with-open-file (s pathname :direction :output
     3254                                :element-type element-type
     3255                                #-gcl2.6 :external-format #-gcl2.6 external-format
     3256                                :if-exists if-exists
     3257                                :if-does-not-exist if-does-not-exist)
     3258      (funcall thunk s)))
     3259
     3260  (defmacro with-output-file ((var pathname &rest keys
     3261                               &key element-type external-format if-exists if-does-not-exist)
     3262                              &body body)
     3263    (declare (ignore element-type external-format if-exists if-does-not-exist))
     3264    `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
    32413265
    32423266;;; Ensure output buffers are flushed
    … …  
    40454069    (slurp-stream-form stream :at at))
    40464070
     4071  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
     4072    (declare (ignorable x))
     4073    (apply 'slurp-input-stream *standard-output* stream keys))
     4074
     4075  (defmethod slurp-input-stream ((pathname pathname) input
     4076                                 &key
     4077                                   (element-type *default-stream-element-type*)
     4078                                   (external-format *utf-8-external-format*)
     4079                                   (if-exists :rename-and-delete)
     4080                                   (if-does-not-exist :create)
     4081                                   buffer-size
     4082                                   linewise)
     4083    (with-output-file (output pathname
     4084                              :element-type element-type
     4085                              :external-format external-format
     4086                              :if-exists if-exists
     4087                              :if-does-not-exist if-does-not-exist)
     4088      (copy-stream-to-stream
     4089       input output
     4090       :element-type element-type :buffer-size buffer-size :linewise linewise)))
     4091
    40474092  (defmethod slurp-input-stream (x stream
    40484093                                 &key linewise prefix (element-type 'character) buffer-size
    … …  
    40824127    "Run program specified by COMMAND,
    40834128either a list of strings specifying a program and list of arguments,
    4084 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
    4085 have its output processed by the OUTPUT processor function
    4086 as per SLURP-INPUT-STREAM,
    4087 or merely output to the inherited standard output if it's NIL.
     4129or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
     4130
    40884131Always call a shell (rather than directly execute the command)
    40894132if FORCE-SHELL is specified.
    4090 Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
    4091 is specified.
    4092 Return the exit status code of the process that was called.
     4133
     4134Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
     4135unless IGNORE-ERROR-STATUS is specified.
     4136
     4137If OUTPUT is either NIL or :INTERACTIVE, then
     4138return the exit status code of the process that was called.
     4139if it was NIL, the output is discarded;
     4140if it was :INTERACTIVE, the output and the input are inherited from the current process.
     4141
     4142Otherwise, the output will be processed by SLURP-INPUT-STREAM,
     4143using OUTPUT as the first argument, and return whatever it returns,
     4144e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
    40934145Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
     4146    ;; TODO: specially recognize :output pathname ?
    40944147    (declare (ignorable ignore-error-status element-type external-format))
    40954148    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
    … …  
    43484401      '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
    43494402
    4350   (defvar *uninteresting-conditions*
     4403  (defvar *usual-uninteresting-conditions*
    43514404    (append
    43524405     ;;#+clozure '(ccl:compiler-warning)
    … …  
    43604413       sb-kernel:undefined-alien-style-warning
    43614414       sb-grovel-unknown-constant-condition ; defined above.
    4362        ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
     4415       sb-ext:implicit-generic-function-warning ;; Controversial.
    43634416       sb-int:package-at-variance
    43644417       sb-kernel:uninteresting-redefinition
    … …  
    43694422       sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
    43704423     '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
     4424    "A suggested value to which to set or bind *uninteresting-conditions*.")
     4425
     4426  (defvar *uninteresting-conditions* '()
    43714427    "Conditions that may be skipped while compiling or loading Lisp code.")
    43724428  (defvar *uninteresting-compiler-conditions* '()
    … …  
    53655421         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    53665422         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    5367          (asdf-version "2.33")
     5423         (asdf-version "2.33.7")
    53685424         (existing-version (asdf-version)))
    53695425    (setf *asdf-version* asdf-version)
    … …  
    64676523  (:export
    64686524   #:operation
    6469    #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
     6525   #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
    64706526   #:build-op ;; THE generic operation
    64716527   #:*operations* #:make-operation #:find-operation #:feature))
    … …  
    73267382          (values done-stamp ;; return the hard-earned timestamp
    73277383                  (or just-done
    7328                       (or out-op ;; a file-creating op is done when all files are up to date
    7329                           ;; a image-effecting a placeholder op is done when it was actually run,
    7330                           (and op-time (eql op-time done-stamp))))) ;; with the matching stamp
     7384                      out-op ;; a file-creating op is done when all files are up to date
     7385                      ;; a image-effecting a placeholder op is done when it was actually run,
     7386                      (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
    73317387          ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
    73327388          (values t nil)))))
    … …  
    74557511  (defgeneric plan-operates-on-p (plan component))
    74567512
    7457   (defparameter *default-plan-class* 'sequential-plan)
     7513  (defvar *default-plan-class* 'sequential-plan)
    74587514
    74597515  (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
    … …  
    77387794
    77397795  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
    7740 
    7741 
    7742 ;;;; ---------------------------------------------------------------------------
    7743 ;;;; asdf-output-translations
    7744 
    7745 (asdf/package:define-package :asdf/output-translations
    7746   (:recycle :asdf/output-translations :asdf)
    7747   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
    7748   (:export
    7749    #:*output-translations* #:*output-translations-parameter*
    7750    #:invalid-output-translation
    7751    #:output-translations #:output-translations-initialized-p
    7752    #:initialize-output-translations #:clear-output-translations
    7753    #:disable-output-translations #:ensure-output-translations
    7754    #:apply-output-translations
    7755    #:validate-output-translations-directive #:validate-output-translations-form
    7756    #:validate-output-translations-file #:validate-output-translations-directory
    7757    #:parse-output-translations-string #:wrapping-output-translations
    7758    #:user-output-translations-pathname #:system-output-translations-pathname
    7759    #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
    7760    #:environment-output-translations #:process-output-translations
    7761    #:compute-output-translations
    7762    #+abcl #:translate-jar-pathname
    7763    ))
    7764 (in-package :asdf/output-translations)
    7765 
    7766 (when-upgrading () (undefine-function '(setf output-translations)))
    7767 
    7768 (with-upgradability ()
    7769   (define-condition invalid-output-translation (invalid-configuration warning)
    7770     ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    7771 
    7772   (defvar *output-translations* ()
    7773     "Either NIL (for uninitialized), or a list of one element,
    7774 said element itself being a sorted list of mappings.
    7775 Each mapping is a pair of a source pathname and destination pathname,
    7776 and the order is by decreasing length of namestring of the source pathname.")
    7777 
    7778   (defun output-translations ()
    7779     (car *output-translations*))
    7780 
    7781   (defun set-output-translations (new-value)
    7782     (setf *output-translations*
    7783           (list
    7784            (stable-sort (copy-list new-value) #'>
    7785                         :key #'(lambda (x)
    7786                                  (etypecase (car x)
    7787                                    ((eql t) -1)
    7788                                    (pathname
    7789                                     (let ((directory (pathname-directory (car x))))
    7790                                       (if (listp directory) (length directory) 0))))))))
    7791     new-value)
    7792   #-gcl2.6
    7793   (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
    7794   #+gcl2.6
    7795   (defsetf output-translations set-output-translations)
    7796 
    7797   (defun output-translations-initialized-p ()
    7798     (and *output-translations* t))
    7799 
    7800   (defun clear-output-translations ()
    7801     "Undoes any initialization of the output translations."
    7802     (setf *output-translations* '())
    7803     (values))
    7804   (register-clear-configuration-hook 'clear-output-translations)
    7805 
    7806   (defun validate-output-translations-directive (directive)
    7807     (or (member directive '(:enable-user-cache :disable-cache nil))
    7808         (and (consp directive)
    7809              (or (and (length=n-p directive 2)
    7810                       (or (and (eq (first directive) :include)
    7811                                (typep (second directive) '(or string pathname null)))
    7812                           (and (location-designator-p (first directive))
    7813                                (or (location-designator-p (second directive))
    7814                                    (location-function-p (second directive))))))
    7815                  (and (length=n-p directive 1)
    7816                       (location-designator-p (first directive)))))))
    7817 
    7818   (defun validate-output-translations-form (form &key location)
    7819     (validate-configuration-form
    7820      form
    7821      :output-translations
    7822      'validate-output-translations-directive
    7823      :location location :invalid-form-reporter 'invalid-output-translation))
    7824 
    7825   (defun validate-output-translations-file (file)
    7826     (validate-configuration-file
    7827      file 'validate-output-translations-form :description "output translations"))
    7828 
    7829   (defun validate-output-translations-directory (directory)
    7830     (validate-configuration-directory
    7831      directory :output-translations 'validate-output-translations-directive
    7832                :invalid-form-reporter 'invalid-output-translation))
    7833 
    7834   (defun parse-output-translations-string (string &key location)
    7835     (cond
    7836       ((or (null string) (equal string ""))
    7837        '(:output-translations :inherit-configuration))
    7838       ((not (stringp string))
    7839        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    7840       ((eql (char string 0) #\")
    7841        (parse-output-translations-string (read-from-string string) :location location))
    7842       ((eql (char string 0) #\()
    7843        (validate-output-translations-form (read-from-string string) :location location))
    7844       (t
    7845        (loop
    7846          :with inherit = nil
    7847          :with directives = ()
    7848          :with start = 0
    7849          :with end = (length string)
    7850          :with source = nil
    7851          :with separator = (inter-directory-separator)
    7852          :for i = (or (position separator string :start start) end) :do
    7853            (let ((s (subseq string start i)))
    7854              (cond
    7855                (source
    7856                 (push (list source (if (equal "" s) nil s)) directives)
    7857                 (setf source nil))
    7858                ((equal "" s)
    7859                 (when inherit
    7860                   (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    7861                          string))
    7862                 (setf inherit t)
    7863                 (push :inherit-configuration directives))
    7864                (t
    7865                 (setf source s)))
    7866              (setf start (1+ i))
    7867              (when (> start end)
    7868                (when source
    7869                  (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    7870                         string))
    7871                (unless inherit
    7872                  (push :ignore-inherited-configuration directives))
    7873                (return `(:output-translations ,@(nreverse directives)))))))))
    7874 
    7875   (defparameter *default-output-translations*
    7876     '(environment-output-translations
    7877       user-output-translations-pathname
    7878       user-output-translations-directory-pathname
    7879       system-output-translations-pathname
    7880       system-output-translations-directory-pathname))
    7881 
    7882   (defun wrapping-output-translations ()
    7883     `(:output-translations
    7884     ;; Some implementations have precompiled ASDF systems,
    7885     ;; so we must disable translations for implementation paths.
    7886       #+(or #|clozure|# ecl mkcl sbcl)
    7887       ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
    7888           (when h `(((,h ,*wild-path*) ()))))
    7889       #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
    7890       ;; All-import, here is where we want user stuff to be:
    7891       :inherit-configuration
    7892       ;; These are for convenience, and can be overridden by the user:
    7893       #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    7894       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    7895       ;; We enable the user cache by default, and here is the place we do:
    7896       :enable-user-cache))
    7897 
    7898   (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
    7899   (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
    7900 
    7901   (defun user-output-translations-pathname (&key (direction :input))
    7902     (in-user-configuration-directory *output-translations-file* :direction direction))
    7903   (defun system-output-translations-pathname (&key (direction :input))
    7904     (in-system-configuration-directory *output-translations-file* :direction direction))
    7905   (defun user-output-translations-directory-pathname (&key (direction :input))
    7906     (in-user-configuration-directory *output-translations-directory* :direction direction))
    7907   (defun system-output-translations-directory-pathname (&key (direction :input))
    7908     (in-system-configuration-directory *output-translations-directory* :direction direction))
    7909   (defun environment-output-translations ()
    7910     (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    7911 
    7912   (defgeneric process-output-translations (spec &key inherit collect))
    7913 
    7914   (defun inherit-output-translations (inherit &key collect)
    7915     (when inherit
    7916       (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    7917 
    7918   (defun* (process-output-translations-directive) (directive &key inherit collect)
    7919     (if (atom directive)
    7920         (ecase directive
    7921           ((:enable-user-cache)
    7922            (process-output-translations-directive '(t :user-cache) :collect collect))
    7923           ((:disable-cache)
    7924            (process-output-translations-directive '(t t) :collect collect))
    7925           ((:inherit-configuration)
    7926            (inherit-output-translations inherit :collect collect))
    7927           ((:ignore-inherited-configuration :ignore-invalid-entries nil)
    7928            nil))
    7929         (let ((src (first directive))
    7930               (dst (second directive)))
    7931           (if (eq src :include)
    7932               (when dst
    7933                 (process-output-translations (pathname dst) :inherit nil :collect collect))
    7934               (when src
    7935                 (let ((trusrc (or (eql src t)
    7936                                   (let ((loc (resolve-location src :ensure-directory t :wilden t)))
    7937                                     (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
    7938                   (cond
    7939                     ((location-function-p dst)
    7940                      (funcall collect
    7941                               (list trusrc
    7942                                     (if (symbolp (second dst))
    7943                                         (fdefinition (second dst))
    7944                                         (eval (second dst))))))
    7945                     ((eq dst t)
    7946                      (funcall collect (list trusrc t)))
    7947                     (t
    7948                      (let* ((trudst (if dst
    7949                                         (resolve-location dst :ensure-directory t :wilden t)
    7950                                         trusrc)))
    7951                        (funcall collect (list trudst t))
    7952                        (funcall collect (list trusrc trudst)))))))))))
    7953 
    7954   (defmethod process-output-translations ((x symbol) &key
    7955                                                        (inherit *default-output-translations*)
    7956                                                        collect)
    7957     (process-output-translations (funcall x) :inherit inherit :collect collect))
    7958   (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
    7959     (cond
    7960       ((directory-pathname-p pathname)
    7961        (process-output-translations (validate-output-translations-directory pathname)
    7962                                     :inherit inherit :collect collect))
    7963       ((probe-file* pathname :truename *resolve-symlinks*)
    7964        (process-output-translations (validate-output-translations-file pathname)
    7965                                     :inherit inherit :collect collect))
    7966       (t
    7967        (inherit-output-translations inherit :collect collect))))
    7968   (defmethod process-output-translations ((string string) &key inherit collect)
    7969     (process-output-translations (parse-output-translations-string string)
    7970                                  :inherit inherit :collect collect))
    7971   (defmethod process-output-translations ((x null) &key inherit collect)
    7972     (declare (ignorable x))
    7973     (inherit-output-translations inherit :collect collect))
    7974   (defmethod process-output-translations ((form cons) &key inherit collect)
    7975     (dolist (directive (cdr (validate-output-translations-form form)))
    7976       (process-output-translations-directive directive :inherit inherit :collect collect)))
    7977 
    7978   (defun compute-output-translations (&optional parameter)
    7979     "read the configuration, return it"
    7980     (remove-duplicates
    7981      (while-collecting (c)
    7982        (inherit-output-translations
    7983         `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
    7984      :test 'equal :from-end t))
    7985 
    7986   (defvar *output-translations-parameter* nil)
    7987 
    7988   (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
    7989     "read the configuration, initialize the internal configuration variable,
    7990 return the configuration"
    7991     (setf *output-translations-parameter* parameter
    7992           (output-translations) (compute-output-translations parameter)))
    7993 
    7994   (defun disable-output-translations ()
    7995     "Initialize output translations in a way that maps every file to itself,
    7996 effectively disabling the output translation facility."
    7997     (initialize-output-translations
    7998      '(:output-translations :disable-cache :ignore-inherited-configuration)))
    7999 
    8000   ;; checks an initial variable to see whether the state is initialized
    8001   ;; or cleared. In the former case, return current configuration; in
    8002   ;; the latter, initialize.  ASDF will call this function at the start
    8003   ;; of (asdf:find-system).
    8004   (defun ensure-output-translations ()
    8005     (if (output-translations-initialized-p)
    8006         (output-translations)
    8007         (initialize-output-translations)))
    8008 
    8009   (defun* (apply-output-translations) (path)
    8010     (etypecase path
    8011       (logical-pathname
    8012        path)
    8013       ((or pathname string)
    8014        (ensure-output-translations)
    8015        (loop* :with p = (resolve-symlinks* path)
    8016               :for (source destination) :in (car *output-translations*)
    8017               :for root = (when (or (eq source t)
    8018                                     (and (pathnamep source)
    8019                                          (not (absolute-pathname-p source))))
    8020                             (pathname-root p))
    8021               :for absolute-source = (cond
    8022                                        ((eq source t) (wilden root))
    8023                                        (root (merge-pathnames* source root))
    8024                                        (t source))
    8025               :when (or (eq source t) (pathname-match-p p absolute-source))
    8026               :return (translate-pathname* p absolute-source destination root source)
    8027               :finally (return p)))))
    8028 
    8029   ;; Hook into asdf/driver's output-translation mechanism
    8030   #-cormanlisp
    8031   (setf *output-translation-function* 'apply-output-translations)
    8032 
    8033   #+abcl
    8034   (defun translate-jar-pathname (source wildcard)
    8035     (declare (ignore wildcard))
    8036     (flet ((normalize-device (pathname)
    8037              (if (find :windows *features*)
    8038                  pathname
    8039                  (make-pathname :defaults pathname :device :unspecific))))
    8040       (let* ((jar
    8041                (pathname (first (pathname-device source))))
    8042              (target-root-directory-namestring
    8043                (format nil "/___jar___file___root___/~@[~A/~]"
    8044                        (and (find :windows *features*)
    8045                             (pathname-device jar))))
    8046              (relative-source
    8047                (relativize-pathname-directory source))
    8048              (relative-jar
    8049                (relativize-pathname-directory (ensure-directory-pathname jar)))
    8050              (target-root-directory
    8051                (normalize-device
    8052                 (pathname-directory-pathname
    8053                  (parse-namestring target-root-directory-namestring))))
    8054              (target-root
    8055                (merge-pathnames* relative-jar target-root-directory))
    8056              (target
    8057                (merge-pathnames* relative-source target-root)))
    8058         (normalize-device (apply-output-translations target))))))
    8059 
    8060 ;;;; -----------------------------------------------------------------
    8061 ;;;; Source Registry Configuration, by Francois-Rene Rideau
    8062 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
    8063 
    8064 (asdf/package:define-package :asdf/source-registry
    8065   (:recycle :asdf/source-registry :asdf)
    8066   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
    8067   (:export
    8068    #:*source-registry-parameter* #:*default-source-registries*
    8069    #:invalid-source-registry
    8070    #:source-registry-initialized-p
    8071    #:initialize-source-registry #:clear-source-registry #:*source-registry*
    8072    #:ensure-source-registry #:*source-registry-parameter*
    8073    #:*default-source-registry-exclusions* #:*source-registry-exclusions*
    8074    #:*wild-asd* #:directory-asd-files #:register-asd-directory
    8075    #:collect-asds-in-directory #:collect-sub*directories-asd-files
    8076    #:validate-source-registry-directive #:validate-source-registry-form
    8077    #:validate-source-registry-file #:validate-source-registry-directory
    8078    #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
    8079    #:user-source-registry #:system-source-registry
    8080    #:user-source-registry-directory #:system-source-registry-directory
    8081    #:environment-source-registry #:process-source-registry
    8082    #:compute-source-registry #:flatten-source-registry
    8083    #:sysdef-source-registry-search))
    8084 (in-package :asdf/source-registry)
    8085 
    8086 (with-upgradability ()
    8087   (define-condition invalid-source-registry (invalid-configuration warning)
    8088     ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    8089 
    8090   ;; Using ack 1.2 exclusions
    8091   (defvar *default-source-registry-exclusions*
    8092     '(".bzr" ".cdv"
    8093       ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    8094       ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    8095       "_sgbak" "autom4te.cache" "cover_db" "_build"
    8096       "debian")) ;; debian often builds stuff under the debian directory... BAD.
    8097 
    8098   (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    8099 
    8100   (defvar *source-registry* nil
    8101     "Either NIL (for uninitialized), or an equal hash-table, mapping
    8102 system names to pathnames of .asd files")
    8103 
    8104   (defun source-registry-initialized-p ()
    8105     (typep *source-registry* 'hash-table))
    8106 
    8107   (defun clear-source-registry ()
    8108     "Undoes any initialization of the source registry."
    8109     (setf *source-registry* nil)
    8110     (values))
    8111   (register-clear-configuration-hook 'clear-source-registry)
    8112 
    8113   (defparameter *wild-asd*
    8114     (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
    8115 
    8116   (defun directory-asd-files (directory)
    8117     (directory-files directory *wild-asd*))
    8118 
    8119   (defun collect-asds-in-directory (directory collect)
    8120     (map () collect (directory-asd-files directory)))
    8121 
    8122   (defun collect-sub*directories-asd-files
    8123       (directory &key (exclude *default-source-registry-exclusions*) collect)
    8124     (collect-sub*directories
    8125      directory
    8126      (constantly t)
    8127      #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
    8128      #'(lambda (dir) (collect-asds-in-directory dir collect))))
    8129 
    8130   (defun validate-source-registry-directive (directive)
    8131     (or (member directive '(:default-registry))
    8132         (and (consp directive)
    8133              (let ((rest (rest directive)))
    8134                (case (first directive)
    8135                  ((:include :directory :tree)
    8136                   (and (length=n-p rest 1)
    8137                        (location-designator-p (first rest))))
    8138                  ((:exclude :also-exclude)
    8139                   (every #'stringp rest))
    8140                  ((:default-registry)
    8141                   (null rest)))))))
    8142 
    8143   (defun validate-source-registry-form (form &key location)
    8144     (validate-configuration-form
    8145      form :source-registry 'validate-source-registry-directive
    8146           :location location :invalid-form-reporter 'invalid-source-registry))
    8147 
    8148   (defun validate-source-registry-file (file)
    8149     (validate-configuration-file
    8150      file 'validate-source-registry-form :description "a source registry"))
    8151 
    8152   (defun validate-source-registry-directory (directory)
    8153     (validate-configuration-directory
    8154      directory :source-registry 'validate-source-registry-directive
    8155                :invalid-form-reporter 'invalid-source-registry))
    8156 
    8157   (defun parse-source-registry-string (string &key location)
    8158     (cond
    8159       ((or (null string) (equal string ""))
    8160        '(:source-registry :inherit-configuration))
    8161       ((not (stringp string))
    8162        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    8163       ((find (char string 0) "\"(")
    8164        (validate-source-registry-form (read-from-string string) :location location))
    8165       (t
    8166        (loop
    8167          :with inherit = nil
    8168          :with directives = ()
    8169          :with start = 0
    8170          :with end = (length string)
    8171          :with separator = (inter-directory-separator)
    8172          :for pos = (position separator string :start start) :do
    8173            (let ((s (subseq string start (or pos end))))
    8174              (flet ((check (dir)
    8175                       (unless (absolute-pathname-p dir)
    8176                         (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
    8177                       dir))
    8178                (cond
    8179                  ((equal "" s) ; empty element: inherit
    8180                   (when inherit
    8181                     (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    8182                            string))
    8183                   (setf inherit t)
    8184                   (push ':inherit-configuration directives))
    8185                  ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
    8186                   (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
    8187                  (t
    8188                   (push `(:directory ,(check s)) directives))))
    8189              (cond
    8190                (pos
    8191                 (setf start (1+ pos)))
    8192                (t
    8193                 (unless inherit
    8194                   (push '(:ignore-inherited-configuration) directives))
    8195                 (return `(:source-registry ,@(nreverse directives))))))))))
    8196 
    8197   (defun register-asd-directory (directory &key recurse exclude collect)
    8198     (if (not recurse)
    8199         (collect-asds-in-directory directory collect)
    8200         (collect-sub*directories-asd-files
    8201          directory :exclude exclude :collect collect)))
    8202 
    8203   (defparameter *default-source-registries*
    8204     '(environment-source-registry
    8205       user-source-registry
    8206       user-source-registry-directory
    8207       system-source-registry
    8208       system-source-registry-directory
    8209       default-source-registry))
    8210 
    8211   (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
    8212   (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
    8213 
    8214   (defun wrapping-source-registry ()
    8215     `(:source-registry
    8216       #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
    8217       #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
    8218       :inherit-configuration
    8219       #+cmu (:tree #p"modules:")
    8220       #+scl (:tree #p"file://modules/")))
    8221   (defun default-source-registry ()
    8222     `(:source-registry
    8223       #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
    8224       ,@(loop :for dir :in
    8225               `(,@(when (os-unix-p)
    8226                     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
    8227                            (subpathname (user-homedir-pathname) ".local/share/"))
    8228                       ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
    8229                             '("/usr/local/share" "/usr/share"))))
    8230                 ,@(when (os-windows-p)
    8231                     (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
    8232               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    8233               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
    8234       :inherit-configuration))
    8235   (defun user-source-registry (&key (direction :input))
    8236     (in-user-configuration-directory *source-registry-file* :direction direction))
    8237   (defun system-source-registry (&key (direction :input))
    8238     (in-system-configuration-directory *source-registry-file* :direction direction))
    8239   (defun user-source-registry-directory (&key (direction :input))
    8240     (in-user-configuration-directory *source-registry-directory* :direction direction))
    8241   (defun system-source-registry-directory (&key (direction :input))
    8242     (in-system-configuration-directory *source-registry-directory* :direction direction))
    8243   (defun environment-source-registry ()
    8244     (getenv "CL_SOURCE_REGISTRY"))
    8245 
    8246   (defgeneric* (process-source-registry) (spec &key inherit register))
    8247 
    8248   (defun* (inherit-source-registry) (inherit &key register)
    8249     (when inherit
    8250       (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    8251 
    8252   (defun* (process-source-registry-directive) (directive &key inherit register)
    8253     (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    8254       (ecase kw
    8255         ((:include)
    8256          (destructuring-bind (pathname) rest
    8257            (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    8258         ((:directory)
    8259          (destructuring-bind (pathname) rest
    8260            (when pathname
    8261              (funcall register (resolve-location pathname :ensure-directory t)))))
    8262         ((:tree)
    8263          (destructuring-bind (pathname) rest
    8264            (when pathname
    8265              (funcall register (resolve-location pathname :ensure-directory t)
    8266                       :recurse t :exclude *source-registry-exclusions*))))
    8267         ((:exclude)
    8268          (setf *source-registry-exclusions* rest))
    8269         ((:also-exclude)
    8270          (appendf *source-registry-exclusions* rest))
    8271         ((:default-registry)
    8272          (inherit-source-registry '(default-source-registry) :register register))
    8273         ((:inherit-configuration)
    8274          (inherit-source-registry inherit :register register))
    8275         ((:ignore-inherited-configuration)
    8276          nil)))
    8277     nil)
    8278 
    8279   (defmethod process-source-registry ((x symbol) &key inherit register)
    8280     (process-source-registry (funcall x) :inherit inherit :register register))
    8281   (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
    8282     (cond
    8283       ((directory-pathname-p pathname)
    8284        (let ((*here-directory* (resolve-symlinks* pathname)))
    8285          (process-source-registry (validate-source-registry-directory pathname)
    8286                                   :inherit inherit :register register)))
    8287       ((probe-file* pathname :truename *resolve-symlinks*)
    8288        (let ((*here-directory* (pathname-directory-pathname pathname)))
    8289          (process-source-registry (validate-source-registry-file pathname)
    8290                                   :inherit inherit :register register)))
    8291       (t
    8292        (inherit-source-registry inherit :register register))))
    8293   (defmethod process-source-registry ((string string) &key inherit register)
    8294     (process-source-registry (parse-source-registry-string string)
    8295                              :inherit inherit :register register))
    8296   (defmethod process-source-registry ((x null) &key inherit register)
    8297     (declare (ignorable x))
    8298     (inherit-source-registry inherit :register register))
    8299   (defmethod process-source-registry ((form cons) &key inherit register)
    8300     (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    8301       (dolist (directive (cdr (validate-source-registry-form form)))
    8302         (process-source-registry-directive directive :inherit inherit :register register))))
    8303 
    8304   (defun flatten-source-registry (&optional parameter)
    8305     (remove-duplicates
    8306      (while-collecting (collect)
    8307        (with-pathname-defaults () ;; be location-independent
    8308          (inherit-source-registry
    8309           `(wrapping-source-registry
    8310             ,parameter
    8311             ,@*default-source-registries*)
    8312           :register #'(lambda (directory &key recurse exclude)
    8313                         (collect (list directory :recurse recurse :exclude exclude))))))
    8314      :test 'equal :from-end t))
    8315 
    8316   ;; Will read the configuration and initialize all internal variables.
    8317   (defun compute-source-registry (&optional parameter (registry *source-registry*))
    8318     (dolist (entry (flatten-source-registry parameter))
    8319       (destructuring-bind (directory &key recurse exclude) entry
    8320         (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    8321           (register-asd-directory
    8322            directory :recurse recurse :exclude exclude :collect
    8323            #'(lambda (asd)
    8324                (let* ((name (pathname-name asd))
    8325                       (name (if (typep asd 'logical-pathname)
    8326                                 ;; logical pathnames are upper-case,
    8327                                 ;; at least in the CLHS and on SBCL,
    8328                                 ;; yet (coerce-name :foo) is lower-case.
    8329                                 ;; won't work well with (load-system "Foo")
    8330                                 ;; instead of (load-system 'foo)
    8331                                 (string-downcase name)
    8332                                 name)))
    8333                  (cond
    8334                    ((gethash name registry) ; already shadowed by something else
    8335                     nil)
    8336                    ((gethash name h) ; conflict at current level
    8337                     (when *verbose-out*
    8338                       (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
    8339                                 found several entries for ~A - picking ~S over ~S~:>")
    8340                             directory recurse name (gethash name h) asd)))
    8341                    (t
    8342                     (setf (gethash name registry) asd)
    8343                     (setf (gethash name h) asd))))))
    8344           h)))
    8345     (values))
    8346 
    8347   (defvar *source-registry-parameter* nil)
    8348 
    8349   (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
    8350     ;; Record the parameter used to configure the registry
    8351     (setf *source-registry-parameter* parameter)
    8352     ;; Clear the previous registry database:
    8353     (setf *source-registry* (make-hash-table :test 'equal))
    8354     ;; Do it!
    8355     (compute-source-registry parameter))
    8356 
    8357   ;; Checks an initial variable to see whether the state is initialized
    8358   ;; or cleared. In the former case, return current configuration; in
    8359   ;; the latter, initialize.  ASDF will call this function at the start
    8360   ;; of (asdf:find-system) to make sure the source registry is initialized.
    8361   ;; However, it will do so *without* a parameter, at which point it
    8362   ;; will be too late to provide a parameter to this function, though
    8363   ;; you may override the configuration explicitly by calling
    8364   ;; initialize-source-registry directly with your parameter.
    8365   (defun ensure-source-registry (&optional parameter)
    8366     (unless (source-registry-initialized-p)
    8367       (initialize-source-registry parameter))
    8368     (values))
    8369 
    8370   (defun sysdef-source-registry-search (system)
    8371     (ensure-source-registry)
    8372     (values (gethash (primary-system-name system) *source-registry*))))
    83737796
    83747797
    … …  
    92678690    (perform-lisp-load-fasl o s)))
    92688691
     8692;;;; ---------------------------------------------------------------------------
     8693;;;; asdf-output-translations
     8694
     8695(asdf/package:define-package :asdf/output-translations
     8696  (:recycle :asdf/output-translations :asdf)
     8697  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
     8698  (:export
     8699   #:*output-translations* #:*output-translations-parameter*
     8700   #:invalid-output-translation
     8701   #:output-translations #:output-translations-initialized-p
     8702   #:initialize-output-translations #:clear-output-translations
     8703   #:disable-output-translations #:ensure-output-translations
     8704   #:apply-output-translations
     8705   #:validate-output-translations-directive #:validate-output-translations-form
     8706   #:validate-output-translations-file #:validate-output-translations-directory
     8707   #:parse-output-translations-string #:wrapping-output-translations
     8708   #:user-output-translations-pathname #:system-output-translations-pathname
     8709   #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
     8710   #:environment-output-translations #:process-output-translations
     8711   #:compute-output-translations
     8712   #+abcl #:translate-jar-pathname
     8713   ))
     8714(in-package :asdf/output-translations)
     8715
     8716(when-upgrading () (undefine-function '(setf output-translations)))
     8717
     8718(with-upgradability ()
     8719  (define-condition invalid-output-translation (invalid-configuration warning)
     8720    ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     8721
     8722  (defvar *output-translations* ()
     8723    "Either NIL (for uninitialized), or a list of one element,
     8724said element itself being a sorted list of mappings.
     8725Each mapping is a pair of a source pathname and destination pathname,
     8726and the order is by decreasing length of namestring of the source pathname.")
     8727
     8728  (defun output-translations ()
     8729    (car *output-translations*))
     8730
     8731  (defun set-output-translations (new-value)
     8732    (setf *output-translations*
     8733          (list
     8734           (stable-sort (copy-list new-value) #'>
     8735                        :key #'(lambda (x)
     8736                                 (etypecase (car x)
     8737                                   ((eql t) -1)
     8738                                   (pathname
     8739                                    (let ((directory (pathname-directory (car x))))
     8740                                      (if (listp directory) (length directory) 0))))))))
     8741    new-value)
     8742  #-gcl2.6
     8743  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
     8744  #+gcl2.6
     8745  (defsetf output-translations set-output-translations)
     8746
     8747  (defun output-translations-initialized-p ()
     8748    (and *output-translations* t))
     8749
     8750  (defun clear-output-translations ()
     8751    "Undoes any initialization of the output translations."
     8752    (setf *output-translations* '())
     8753    (values))
     8754  (register-clear-configuration-hook 'clear-output-translations)
     8755
     8756  (defun validate-output-translations-directive (directive)
     8757    (or (member directive '(:enable-user-cache :disable-cache nil))
     8758        (and (consp directive)
     8759             (or (and (length=n-p directive 2)
     8760                      (or (and (eq (first directive) :include)
     8761                               (typep (second directive) '(or string pathname null)))
     8762                          (and (location-designator-p (first directive))
     8763                               (or (location-designator-p (second directive))
     8764                                   (location-function-p (second directive))))))
     8765                 (and (length=n-p directive 1)
     8766                      (location-designator-p (first directive)))))))
     8767
     8768  (defun validate-output-translations-form (form &key location)
     8769    (validate-configuration-form
     8770     form
     8771     :output-translations
     8772     'validate-output-translations-directive
     8773     :location location :invalid-form-reporter 'invalid-output-translation))
     8774
     8775  (defun validate-output-translations-file (file)
     8776    (validate-configuration-file
     8777     file 'validate-output-translations-form :description "output translations"))
     8778
     8779  (defun validate-output-translations-directory (directory)
     8780    (validate-configuration-directory
     8781     directory :output-translations 'validate-output-translations-directive
     8782               :invalid-form-reporter 'invalid-output-translation))
     8783
     8784  (defun parse-output-translations-string (string &key location)
     8785    (cond
     8786      ((or (null string) (equal string ""))
     8787       '(:output-translations :inherit-configuration))
     8788      ((not (stringp string))
     8789       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     8790      ((eql (char string 0) #\")
     8791       (parse-output-translations-string (read-from-string string) :location location))
     8792      ((eql (char string 0) #\()
     8793       (validate-output-translations-form (read-from-string string) :location location))
     8794      (t
     8795       (loop
     8796         :with inherit = nil
     8797         :with directives = ()
     8798         :with start = 0
     8799         :with end = (length string)
     8800         :with source = nil
     8801         :with separator = (inter-directory-separator)
     8802         :for i = (or (position separator string :start start) end) :do
     8803           (let ((s (subseq string start i)))
     8804             (cond
     8805               (source
     8806                (push (list source (if (equal "" s) nil s)) directives)
     8807                (setf source nil))
     8808               ((equal "" s)
     8809                (when inherit
     8810                  (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     8811                         string))
     8812                (setf inherit t)
     8813                (push :inherit-configuration directives))
     8814               (t
     8815                (setf source s)))
     8816             (setf start (1+ i))
     8817             (when (> start end)
     8818               (when source
     8819                 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
     8820                        string))
     8821               (unless inherit
     8822                 (push :ignore-inherited-configuration directives))
     8823               (return `(:output-translations ,@(nreverse directives)))))))))
     8824
     8825  (defparameter *default-output-translations*
     8826    '(environment-output-translations
     8827      user-output-translations-pathname
     8828      user-output-translations-directory-pathname
     8829      system-output-translations-pathname
     8830      system-output-translations-directory-pathname))
     8831
     8832  (defun wrapping-output-translations ()
     8833    `(:output-translations
     8834    ;; Some implementations have precompiled ASDF systems,
     8835    ;; so we must disable translations for implementation paths.
     8836      #+(or #|clozure|# ecl mkcl sbcl)
     8837      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
     8838          (when h `(((,h ,*wild-path*) ()))))
     8839      #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
     8840      ;; All-import, here is where we want user stuff to be:
     8841      :inherit-configuration
     8842      ;; These are for convenience, and can be overridden by the user:
     8843      #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     8844      #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     8845      ;; We enable the user cache by default, and here is the place we do:
     8846      :enable-user-cache))
     8847
     8848  (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
     8849  (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
     8850
     8851  (defun user-output-translations-pathname (&key (direction :input))
     8852    (in-user-configuration-directory *output-translations-file* :direction direction))
     8853  (defun system-output-translations-pathname (&key (direction :input))
     8854    (in-system-configuration-directory *output-translations-file* :direction direction))
     8855  (defun user-output-translations-directory-pathname (&key (direction :input))
     8856    (in-user-configuration-directory *output-translations-directory* :direction direction))
     8857  (defun system-output-translations-directory-pathname (&key (direction :input))
     8858    (in-system-configuration-directory *output-translations-directory* :direction direction))
     8859  (defun environment-output-translations ()
     8860    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     8861
     8862  (defgeneric process-output-translations (spec &key inherit collect))
     8863
     8864  (defun inherit-output-translations (inherit &key collect)
     8865    (when inherit
     8866      (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
     8867
     8868  (defun* (process-output-translations-directive) (directive &key inherit collect)
     8869    (if (atom directive)
     8870        (ecase directive
     8871          ((:enable-user-cache)
     8872           (process-output-translations-directive '(t :user-cache) :collect collect))
     8873          ((:disable-cache)
     8874           (process-output-translations-directive '(t t) :collect collect))
     8875          ((:inherit-configuration)
     8876           (inherit-output-translations inherit :collect collect))
     8877          ((:ignore-inherited-configuration :ignore-invalid-entries nil)
     8878           nil))
     8879        (let ((src (first directive))
     8880              (dst (second directive)))
     8881          (if (eq src :include)
     8882              (when dst
     8883                (process-output-translations (pathname dst) :inherit nil :collect collect))
     8884              (when src
     8885                (let ((trusrc (or (eql src t)
     8886                                  (let ((loc (resolve-location src :ensure-directory t :wilden t)))
     8887                                    (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
     8888                  (cond
     8889                    ((location-function-p dst)
     8890                     (funcall collect
     8891                              (list trusrc
     8892                                    (if (symbolp (second dst))
     8893                                        (fdefinition (second dst))
     8894                                        (eval (second dst))))))
     8895                    ((eq dst t)
     8896                     (funcall collect (list trusrc t)))
     8897                    (t
     8898                     (let* ((trudst (if dst
     8899                                        (resolve-location dst :ensure-directory t :wilden t)
     8900                                        trusrc)))
     8901                       (funcall collect (list trudst t))
     8902                       (funcall collect (list trusrc trudst)))))))))))
     8903
     8904  (defmethod process-output-translations ((x symbol) &key
     8905                                                       (inherit *default-output-translations*)
     8906                                                       collect)
     8907    (process-output-translations (funcall x) :inherit inherit :collect collect))
     8908  (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
     8909    (cond
     8910      ((directory-pathname-p pathname)
     8911       (process-output-translations (validate-output-translations-directory pathname)
     8912                                    :inherit inherit :collect collect))
     8913      ((probe-file* pathname :truename *resolve-symlinks*)
     8914       (process-output-translations (validate-output-translations-file pathname)
     8915                                    :inherit inherit :collect collect))
     8916      (t
     8917       (inherit-output-translations inherit :collect collect))))
     8918  (defmethod process-output-translations ((string string) &key inherit collect)
     8919    (process-output-translations (parse-output-translations-string string)
     8920                                 :inherit inherit :collect collect))
     8921  (defmethod process-output-translations ((x null) &key inherit collect)
     8922    (declare (ignorable x))
     8923    (inherit-output-translations inherit :collect collect))
     8924  (defmethod process-output-translations ((form cons) &key inherit collect)
     8925    (dolist (directive (cdr (validate-output-translations-form form)))
     8926      (process-output-translations-directive directive :inherit inherit :collect collect)))
     8927
     8928  (defun compute-output-translations (&optional parameter)
     8929    "read the configuration, return it"
     8930    (remove-duplicates
     8931     (while-collecting (c)
     8932       (inherit-output-translations
     8933        `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
     8934     :test 'equal :from-end t))
     8935
     8936  (defvar *output-translations-parameter* nil)
     8937
     8938  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
     8939    "read the configuration, initialize the internal configuration variable,
     8940return the configuration"
     8941    (setf *output-translations-parameter* parameter
     8942          (output-translations) (compute-output-translations parameter)))
     8943
     8944  (defun disable-output-translations ()
     8945    "Initialize output translations in a way that maps every file to itself,
     8946effectively disabling the output translation facility."
     8947    (initialize-output-translations
     8948     '(:output-translations :disable-cache :ignore-inherited-configuration)))
     8949
     8950  ;; checks an initial variable to see whether the state is initialized
     8951  ;; or cleared. In the former case, return current configuration; in
     8952  ;; the latter, initialize.  ASDF will call this function at the start
     8953  ;; of (asdf:find-system).
     8954  (defun ensure-output-translations ()
     8955    (if (output-translations-initialized-p)
     8956        (output-translations)
     8957        (initialize-output-translations)))
     8958
     8959  (defun* (apply-output-translations) (path)
     8960    (etypecase path
     8961      (logical-pathname
     8962       path)
     8963      ((or pathname string)
     8964       (ensure-output-translations)
     8965       (loop* :with p = (resolve-symlinks* path)
     8966              :for (source destination) :in (car *output-translations*)
     8967              :for root = (when (or (eq source t)
     8968                                    (and (pathnamep source)
     8969                                         (not (absolute-pathname-p source))))
     8970                            (pathname-root p))
     8971              :for absolute-source = (cond
     8972                                       ((eq source t) (wilden root))
     8973                                       (root (merge-pathnames* source root))
     8974                                       (t source))
     8975              :when (or (eq source t) (pathname-match-p p absolute-source))
     8976              :return (translate-pathname* p absolute-source destination root source)
     8977              :finally (return p)))))
     8978
     8979  ;; Hook into asdf/driver's output-translation mechanism
     8980  #-cormanlisp
     8981  (setf *output-translation-function* 'apply-output-translations)
     8982
     8983  #+abcl
     8984  (defun translate-jar-pathname (source wildcard)
     8985    (declare (ignore wildcard))
     8986    (flet ((normalize-device (pathname)
     8987             (if (find :windows *features*)
     8988                 pathname
     8989                 (make-pathname :defaults pathname :device :unspecific))))
     8990      (let* ((jar
     8991               (pathname (first (pathname-device source))))
     8992             (target-root-directory-namestring
     8993               (format nil "/___jar___file___root___/~@[~A/~]"
     8994                       (and (find :windows *features*)
     8995                            (pathname-device jar))))
     8996             (relative-source
     8997               (relativize-pathname-directory source))
     8998             (relative-jar
     8999               (relativize-pathname-directory (ensure-directory-pathname jar)))
     9000             (target-root-directory
     9001               (normalize-device
     9002                (pathname-directory-pathname
     9003                 (parse-namestring target-root-directory-namestring))))
     9004             (target-root
     9005               (merge-pathnames* relative-jar target-root-directory))
     9006             (target
     9007               (merge-pathnames* relative-source target-root)))
     9008        (normalize-device (apply-output-translations target))))))
     9009
    92699010;;;; -------------------------------------------------------------------------
    92709011;;; Backward-compatible interfaces
    … …  
    94009141PLEASE DO NOT USE.
    94019142Deprecated function, for backward-compatibility only.
    9402 Please use ASDF-DRIVER:RUN-PROGRAM instead."
     9143Please use UIOP:RUN-PROGRAM instead."
    94039144    (let ((command (apply 'format nil control-string args)))
    94049145      (asdf-message "; $ ~A~%" command)
    … …  
    94239164                (acons property new-value (slot-value c 'properties)))))
    94249165    new-value))
     9166;;;; -----------------------------------------------------------------
     9167;;;; Source Registry Configuration, by Francois-Rene Rideau
     9168;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     9169
     9170(asdf/package:define-package :asdf/source-registry
     9171  (:recycle :asdf/source-registry :asdf)
     9172  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
     9173  (:export
     9174   #:*source-registry-parameter* #:*default-source-registries*
     9175   #:invalid-source-registry
     9176   #:source-registry-initialized-p
     9177   #:initialize-source-registry #:clear-source-registry #:*source-registry*
     9178   #:ensure-source-registry #:*source-registry-parameter*
     9179   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
     9180   #:*wild-asd* #:directory-asd-files #:register-asd-directory
     9181   #:collect-asds-in-directory #:collect-sub*directories-asd-files
     9182   #:validate-source-registry-directive #:validate-source-registry-form
     9183   #:validate-source-registry-file #:validate-source-registry-directory
     9184   #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
     9185   #:user-source-registry #:system-source-registry
     9186   #:user-source-registry-directory #:system-source-registry-directory
     9187   #:environment-source-registry #:process-source-registry
     9188   #:compute-source-registry #:flatten-source-registry
     9189   #:sysdef-source-registry-search))
     9190(in-package :asdf/source-registry)
     9191
     9192(with-upgradability ()
     9193  (define-condition invalid-source-registry (invalid-configuration warning)
     9194    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     9195
     9196  ;; Using ack 1.2 exclusions
     9197  (defvar *default-source-registry-exclusions*
     9198    '(".bzr" ".cdv"
     9199      ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
     9200      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     9201      "_sgbak" "autom4te.cache" "cover_db" "_build"
     9202      "debian")) ;; debian often builds stuff under the debian directory... BAD.
     9203
     9204  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     9205
     9206  (defvar *source-registry* nil
     9207    "Either NIL (for uninitialized), or an equal hash-table, mapping
     9208system names to pathnames of .asd files")
     9209
     9210  (defun source-registry-initialized-p ()
     9211    (typep *source-registry* 'hash-table))
     9212
     9213  (defun clear-source-registry ()
     9214    "Undoes any initialization of the source registry."
     9215    (setf *source-registry* nil)
     9216    (values))
     9217  (register-clear-configuration-hook 'clear-source-registry)
     9218
     9219  (defparameter *wild-asd*
     9220    (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
     9221
     9222  (defun directory-asd-files (directory)
     9223    (directory-files directory *wild-asd*))
     9224
     9225  (defun collect-asds-in-directory (directory collect)
     9226    (map () collect (directory-asd-files directory)))
     9227
     9228  (defun collect-sub*directories-asd-files
     9229      (directory &key (exclude *default-source-registry-exclusions*) collect)
     9230    (collect-sub*directories
     9231     directory
     9232     (constantly t)
     9233     #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
     9234     #'(lambda (dir) (collect-asds-in-directory dir collect))))
     9235
     9236  (defun validate-source-registry-directive (directive)
     9237    (or (member directive '(:default-registry))
     9238        (and (consp directive)
     9239             (let ((rest (rest directive)))
     9240               (case (first directive)
     9241                 ((:include :directory :tree)
     9242                  (and (length=n-p rest 1)
     9243                       (location-designator-p (first rest))))
     9244                 ((:exclude :also-exclude)
     9245                  (every #'stringp rest))
     9246                 ((:default-registry)
     9247                  (null rest)))))))
     9248
     9249  (defun validate-source-registry-form (form &key location)
     9250    (validate-configuration-form
     9251     form :source-registry 'validate-source-registry-directive
     9252          :location location :invalid-form-reporter 'invalid-source-registry))
     9253
     9254  (defun validate-source-registry-file (file)
     9255    (validate-configuration-file
     9256     file 'validate-source-registry-form :description "a source registry"))
     9257
     9258  (defun validate-source-registry-directory (directory)
     9259    (validate-configuration-directory
     9260     directory :source-registry 'validate-source-registry-directive
     9261               :invalid-form-reporter 'invalid-source-registry))
     9262
     9263  (defun parse-source-registry-string (string &key location)
     9264    (cond
     9265      ((or (null string) (equal string ""))
     9266       '(:source-registry :inherit-configuration))
     9267      ((not (stringp string))
     9268       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     9269      ((find (char string 0) "\"(")
     9270       (validate-source-registry-form (read-from-string string) :location location))
     9271      (t
     9272       (loop
     9273         :with inherit = nil
     9274         :with directives = ()
     9275         :with start = 0
     9276         :with end = (length string)
     9277         :with separator = (inter-directory-separator)
     9278         :for pos = (position separator string :start start) :do
     9279           (let ((s (subseq string start (or pos end))))
     9280             (flet ((check (dir)
     9281                      (unless (absolute-pathname-p dir)
     9282                        (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
     9283                      dir))
     9284               (cond
     9285                 ((equal "" s) ; empty element: inherit
     9286                  (when inherit
     9287                    (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     9288                           string))
     9289                  (setf inherit t)
     9290                  (push ':inherit-configuration directives))
     9291                 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
     9292                  (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
     9293                 (t
     9294                  (push `(:directory ,(check s)) directives))))
     9295             (cond
     9296               (pos
     9297                (setf start (1+ pos)))
     9298               (t
     9299                (unless inherit
     9300                  (push '(:ignore-inherited-configuration) directives))
     9301                (return `(:source-registry ,@(nreverse directives))))))))))
     9302
     9303  (defun register-asd-directory (directory &key recurse exclude collect)
     9304    (if (not recurse)
     9305        (collect-asds-in-directory directory collect)
     9306        (collect-sub*directories-asd-files
     9307         directory :exclude exclude :collect collect)))
     9308
     9309  (defparameter *default-source-registries*
     9310    '(environment-source-registry
     9311      user-source-registry
     9312      user-source-registry-directory
     9313      system-source-registry
     9314      system-source-registry-directory
     9315      default-source-registry))
     9316
     9317  (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
     9318  (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
     9319
     9320  (defun wrapping-source-registry ()
     9321    `(:source-registry
     9322      #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
     9323      #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     9324      :inherit-configuration
     9325      #+cmu (:tree #p"modules:")
     9326      #+scl (:tree #p"file://modules/")))
     9327  (defun default-source-registry ()
     9328    `(:source-registry
     9329      #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
     9330      ,@(loop :for dir :in
     9331              `(,@(when (os-unix-p)
     9332                    `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
     9333                           (subpathname (user-homedir-pathname) ".local/share/"))
     9334                      ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
     9335                            '("/usr/local/share" "/usr/share"))))
     9336                ,@(when (os-windows-p)
     9337                    (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
     9338              :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
     9339              :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     9340      :inherit-configuration))
     9341  (defun user-source-registry (&key (direction :input))
     9342    (in-user-configuration-directory *source-registry-file* :direction direction))
     9343  (defun system-source-registry (&key (direction :input))
     9344    (in-system-configuration-directory *source-registry-file* :direction direction))
     9345  (defun user-source-registry-directory (&key (direction :input))
     9346    (in-user-configuration-directory *source-registry-directory* :direction direction))
     9347  (defun system-source-registry-directory (&key (direction :input))
     9348    (in-system-configuration-directory *source-registry-directory* :direction direction))
     9349  (defun environment-source-registry ()
     9350    (getenv "CL_SOURCE_REGISTRY"))
     9351
     9352  (defgeneric* (process-source-registry) (spec &key inherit register))
     9353
     9354  (defun* (inherit-source-registry) (inherit &key register)
     9355    (when inherit
     9356      (process-source-registry (first inherit) :register register :inherit (rest inherit))))
     9357
     9358  (defun* (process-source-registry-directive) (directive &key inherit register)
     9359    (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     9360      (ecase kw
     9361        ((:include)
     9362         (destructuring-bind (pathname) rest
     9363           (process-source-registry (resolve-location pathname) :inherit nil :register register)))
     9364        ((:directory)
     9365         (destructuring-bind (pathname) rest
     9366           (when pathname
     9367             (funcall register (resolve-location pathname :ensure-directory t)))))
     9368        ((:tree)
     9369         (destructuring-bind (pathname) rest
     9370           (when pathname
     9371             (funcall register (resolve-location pathname :ensure-directory t)
     9372                      :recurse t :exclude *source-registry-exclusions*))))
     9373        ((:exclude)
     9374         (setf *source-registry-exclusions* rest))
     9375        ((:also-exclude)
     9376         (appendf *source-registry-exclusions* rest))
     9377        ((:default-registry)
     9378         (inherit-source-registry '(default-source-registry) :register register))
     9379        ((:inherit-configuration)
     9380         (inherit-source-registry inherit :register register))
     9381        ((:ignore-inherited-configuration)
     9382         nil)))
     9383    nil)
     9384
     9385  (defmethod process-source-registry ((x symbol) &key inherit register)
     9386    (process-source-registry (funcall x) :inherit inherit :register register))
     9387  (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
     9388    (cond
     9389      ((directory-pathname-p pathname)
     9390       (let ((*here-directory* (resolve-symlinks* pathname)))
     9391         (process-source-registry (validate-source-registry-directory pathname)
     9392                                  :inherit inherit :register register)))
     9393      ((probe-file* pathname :truename *resolve-symlinks*)
     9394       (let ((*here-directory* (pathname-directory-pathname pathname)))
     9395         (process-source-registry (validate-source-registry-file pathname)
     9396                                  :inherit inherit :register register)))
     9397      (t
     9398       (inherit-source-registry inherit :register register))))
     9399  (defmethod process-source-registry ((string string) &key inherit register)
     9400    (process-source-registry (parse-source-registry-string string)
     9401                             :inherit inherit :register register))
     9402  (defmethod process-source-registry ((x null) &key inherit register)
     9403    (declare (ignorable x))
     9404    (inherit-source-registry inherit :register register))
     9405  (defmethod process-source-registry ((form cons) &key inherit register)
     9406    (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
     9407      (dolist (directive (cdr (validate-source-registry-form form)))
     9408        (process-source-registry-directive directive :inherit inherit :register register))))
     9409
     9410  (defun flatten-source-registry (&optional parameter)
     9411    (remove-duplicates
     9412     (while-collecting (collect)
     9413       (with-pathname-defaults () ;; be location-independent
     9414         (inherit-source-registry
     9415          `(wrapping-source-registry
     9416            ,parameter
     9417            ,@*default-source-registries*)
     9418          :register #'(lambda (directory &key recurse exclude)
     9419                        (collect (list directory :recurse recurse :exclude exclude))))))
     9420     :test 'equal :from-end t))
     9421
     9422  ;; Will read the configuration and initialize all internal variables.
     9423  (defun compute-source-registry (&optional parameter (registry *source-registry*))
     9424    (dolist (entry (flatten-source-registry parameter))
     9425      (destructuring-bind (directory &key recurse exclude) entry
     9426        (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
     9427          (register-asd-directory
     9428           directory :recurse recurse :exclude exclude :collect
     9429           #'(lambda (asd)
     9430               (let* ((name (pathname-name asd))
     9431                      (name (if (typep asd 'logical-pathname)
     9432                                ;; logical pathnames are upper-case,
     9433                                ;; at least in the CLHS and on SBCL,
     9434                                ;; yet (coerce-name :foo) is lower-case.
     9435                                ;; won't work well with (load-system "Foo")
     9436                                ;; instead of (load-system 'foo)
     9437                                (string-downcase name)
     9438                                name)))
     9439                 (cond
     9440                   ((gethash name registry) ; already shadowed by something else
     9441                    nil)
     9442                   ((gethash name h) ; conflict at current level
     9443                    (when *verbose-out*
     9444                      (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     9445                                found several entries for ~A - picking ~S over ~S~:>")
     9446                            directory recurse name (gethash name h) asd)))
     9447                   (t
     9448                    (setf (gethash name registry) asd)
     9449                    (setf (gethash name h) asd))))))
     9450          h)))
     9451    (values))
     9452
     9453  (defvar *source-registry-parameter* nil)
     9454
     9455  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
     9456    ;; Record the parameter used to configure the registry
     9457    (setf *source-registry-parameter* parameter)
     9458    ;; Clear the previous registry database:
     9459    (setf *source-registry* (make-hash-table :test 'equal))
     9460    ;; Do it!
     9461    (compute-source-registry parameter))
     9462
     9463  ;; Checks an initial variable to see whether the state is initialized
     9464  ;; or cleared. In the former case, return current configuration; in
     9465  ;; the latter, initialize.  ASDF will call this function at the start
     9466  ;; of (asdf:find-system) to make sure the source registry is initialized.
     9467  ;; However, it will do so *without* a parameter, at which point it
     9468  ;; will be too late to provide a parameter to this function, though
     9469  ;; you may override the configuration explicitly by calling
     9470  ;; initialize-source-registry directly with your parameter.
     9471  (defun ensure-source-registry (&optional parameter)
     9472    (unless (source-registry-initialized-p)
     9473      (initialize-source-registry parameter))
     9474    (values))
     9475
     9476  (defun sysdef-source-registry-search (system)
     9477    (ensure-source-registry)
     9478    (values (gethash (primary-system-name system) *source-registry*))))
     9479
     9480
    94259481;;;; ---------------------------------------------------------------------------
    94269482;;;; Handle ASDF package upgrade, including implementation-dependent magic.
    … …  
    94449500  (:export
    94459501   #:defsystem #:find-system #:locate-system #:coerce-name
    9446    #:oos #:operate #:traverse #:perform-plan
     9502   #:oos #:operate #:traverse #:perform-plan #:sequential-plan
    94479503   #:system-definition-pathname #:with-system-definitions
    94489504   #:search-for-system-definition #:find-component #:component-find-path
Note: See TracChangeset for help on using the changeset viewer.