Commit d6c42afd authored by Gary King's avatar Gary King
Browse files

Added load-preferences and preference-file-for-system/operation. Specialized

them so that preferences are found in ~/.asdf/<name-of-system>.lisp by default
and are loaded on either a load-op or a load-source-op. Refactored load-op and
load-source-op to both be subclasses of basic-load-op to facilitate this.

Added test case in test directory.

Still need to add to documentation of ASDF and will once I figure out where such
a beast truely lives.
parent 135437fb
;;; This is asdf: Another System Definition Facility. $Revision: 1.99 $
;;; This is asdf: Another System Definition Facility. $Revision: 1.100 $
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical
......@@ -101,6 +101,8 @@
#:retry
#:accept ; restarts
#:preference-file-for-system/operation
#:load-preferences
)
(:use :cl))
......@@ -110,7 +112,7 @@
(in-package #:asdf)
(defvar *asdf-revision* (let* ((v "$Revision: 1.99 $")
(defvar *asdf-revision* (let* ((v "$Revision: 1.100 $")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
......@@ -732,34 +734,35 @@ system."))
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
(get-universal-time)))
(get-universal-time))
(load-preferences c operation))
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))
#-:broken-fasl-loader
(let ((source-file (component-pathname c))
(output-file (car (output-files operation c))))
(output-file (car (output-files operation c))))
(multiple-value-bind (output warnings-p failure-p)
(compile-file source-file
:output-file output-file)
(compile-file source-file
:output-file output-file)
;(declare (ignore output))
(when warnings-p
(case (operation-on-warnings operation)
(:warn (warn
"~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
operation c))
(:error (error 'compile-warned :component c :operation operation))
(:ignore nil)))
(case (operation-on-warnings operation)
(:warn (warn
"~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
operation c))
(:error (error 'compile-warned :component c :operation operation))
(:ignore nil)))
(when failure-p
(case (operation-on-failure operation)
(:warn (warn
"~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
operation c))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))
(case (operation-on-failure operation)
(:warn (warn
"~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
operation c))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))
(unless output
(error 'compile-error :component c :operation operation)))))
(error 'compile-error :component c :operation operation)))))
(defmethod output-files ((operation compile-op) (c cl-source-file))
#-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
......@@ -773,7 +776,9 @@ system."))
;;; load-op
(defclass load-op (operation) ())
(defclass basic-load-op (operation) ())
(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
(mapcar #'load (input-files o c)))
......@@ -792,7 +797,7 @@ system."))
;;; load-source-op
(defclass load-source-op (operation) ())
(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))
(let ((source (component-pathname c)))
......@@ -827,6 +832,38 @@ system."))
(defmethod perform ((operation test-op) (c component))
nil)
(defgeneric load-preferences (system operation)
(:documentation "Called to load system preferences after <perform operation system>. Typical uses are to set parameters that don't exist until after the system has been loaded."))
(defgeneric preference-file-for-system/operation (system operation)
(:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load."))
(defmethod load-preferences ((s t) (operation t))
;; do nothing
(values))
(defmethod load-preferences ((s system) (operation basic-load-op))
(let* ((*package* (find-package :common-lisp))
(file (probe-file (preference-file-for-system/operation s operation))))
(when file
(when *verbose-out*
(format *verbose-out*
"~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
(component-name s)
(type-of operation) file))
(load file))))
(defmethod preference-file-for-system/operation ((system t) (operation t))
;; cope with anything other than systems
(preference-file-for-system/operation (find-system system t) operation))
(defmethod preference-file-for-system/operation ((s system) (operation t))
(merge-pathnames
(make-pathname :name (component-name s)
:type "lisp"
:directory '(:relative ".asdf"))
(truename (user-homedir-pathname))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
......@@ -1173,3 +1210,4 @@ output to *VERBOSE-OUT*. Returns the shell's exit code."
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
(provide 'asdf)
(in-package #:common-lisp-user)
(defvar *test-preferences-variable-1* :default)
;;; -*- Lisp -*-
(load "../asdf")
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(in-package :asdf)
(asdf:oos 'asdf:load-op 'test-preferences-system-1)
(assert (eq common-lisp-user::*test-preferences-variable-1* :load))
(asdf:oos 'asdf:test-op 'test-preferences-system-1)
(assert (eq common-lisp-user::*test-preferences-variable-1* :test))
;;; -*- Lisp -*-
(in-package #:common-lisp)
(defpackage #:test-preferences-1-asdf-system
(:use #:common-lisp #:asdf))
(in-package #:asdf)
(defsystem test-preferences-system-1
:components
((:file "test-preferences-1"))
:in-order-to ((test-op (load-op test-preferences-system-1))))
(defmethod operation-done-p
((o test-op)
(c (eql (find-system 'test-preferences-system-1))))
(values nil))
(defmethod load-preferences
((system (eql (find-system 'test-preferences-system-1)))
(operation test-op))
;; the default load-preferences does nothing for anything other than a
;; basic-load-op. So, ... we hack it
(load (make-pathname
:name "test-preferences-system-test"
:type "lisp"
:defaults *default-pathname-defaults*)))
(defmethod preference-file-for-system/operation
((system (eql (find-system 'test-preferences-system-1)))
(operation load-op))
(make-pathname
:name "test-preferences-system-load"
:type "lisp"
:defaults *default-pathname-defaults*))
(in-package #:common-lisp-user)
(setf *test-preferences-variable-1* :load)
(in-package #:common-lisp-user)
(setf *test-preferences-variable-1* :test)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment