From d6c42afd27ed6a1cf0e58cf3b09ba3dfcb20106c Mon Sep 17 00:00:00 2001 From: Gary King <gwking@metabang.com> Date: Thu, 6 Jul 2006 02:25:59 +0000 Subject: [PATCH] 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. --- asdf.lisp | 80 +++++++++++++++++++------- test/test-preferences-1.lisp | 3 + test/test-preferences-1.script | 9 +++ test/test-preferences-system-1.asd | 35 +++++++++++ test/test-preferences-system-load.lisp | 3 + test/test-preferences-system-test.lisp | 3 + 6 files changed, 112 insertions(+), 21 deletions(-) create mode 100644 test/test-preferences-1.lisp create mode 100644 test/test-preferences-1.script create mode 100644 test/test-preferences-system-1.asd create mode 100644 test/test-preferences-system-load.lisp create mode 100644 test/test-preferences-system-test.lisp diff --git a/asdf.lisp b/asdf.lisp index b04fab1f..f865f511 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,4 +1,4 @@ -;;; 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) + diff --git a/test/test-preferences-1.lisp b/test/test-preferences-1.lisp new file mode 100644 index 00000000..f4b71114 --- /dev/null +++ b/test/test-preferences-1.lisp @@ -0,0 +1,3 @@ +(in-package #:common-lisp-user) + +(defvar *test-preferences-variable-1* :default) diff --git a/test/test-preferences-1.script b/test/test-preferences-1.script new file mode 100644 index 00000000..e0eb1b03 --- /dev/null +++ b/test/test-preferences-1.script @@ -0,0 +1,9 @@ +;;; -*- 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)) diff --git a/test/test-preferences-system-1.asd b/test/test-preferences-system-1.asd new file mode 100644 index 00000000..d8f6444a --- /dev/null +++ b/test/test-preferences-system-1.asd @@ -0,0 +1,35 @@ +;;; -*- 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*)) + diff --git a/test/test-preferences-system-load.lisp b/test/test-preferences-system-load.lisp new file mode 100644 index 00000000..0906efcd --- /dev/null +++ b/test/test-preferences-system-load.lisp @@ -0,0 +1,3 @@ +(in-package #:common-lisp-user) + +(setf *test-preferences-variable-1* :load) diff --git a/test/test-preferences-system-test.lisp b/test/test-preferences-system-test.lisp new file mode 100644 index 00000000..8dd07353 --- /dev/null +++ b/test/test-preferences-system-test.lisp @@ -0,0 +1,3 @@ +(in-package #:common-lisp-user) + +(setf *test-preferences-variable-1* :test) -- GitLab