October 2007 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2182 - branches
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 11:39:18 -0400 (Thu, 04 Oct 2007) New Revision: 2182 Added: branches/trunk-reorg/ Log: Create branch to reorganize directory structure. Copied: branches/trunk-reorg (from rev 2181, trunk)

1 0

[bknr-cvs] r2181 - branches/bos/projects/quickhoney/src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 11:27:54 -0400 (Thu, 04 Oct 2007) New Revision: 2181 Added: branches/bos/projects/quickhoney/src/todo-filme Log: save this file for later Added: branches/bos/projects/quickhoney/src/todo-filme =================================================================== --- branches/bos/projects/quickhoney/src/todo-filme 2007-10-04 07:41:40 UTC (rev 2180) +++ branches/bos/projects/quickhoney/src/todo-filme 2007-10-04 15:27:54 UTC (rev 2181) @@ -0,0 +1,17 @@ +Nachr�stung von Filmen in mehreren Formaten: + +in animation-handler: mime-type anhand blob-type setzen + +in upload-animation-handler: blob-type anhand uploaded-file-type setzen + +dazu: + +in web-utils.lisp mehr informationen �ber die hochgeladenen files abspeichern, insbesondere mime-type + + +Log: + +16. Juli 1h Einarbeitung, 4h Upload-Typen mitf�hren, Fehlermeldung bei +ung�ltigem Dateityp, nicht mehr ben�tigte Filme l�schen, Quicktime und +Shockwave anzeigen, getestet. Shockwave noch unklar wegen +Positionierung, IE geht noch nicht.

1 0

[bknr-cvs] r2180 - in trunk/bknr/src: . data indices sysclasses utils web xml-impex
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 03:41:40 -0400 (Thu, 04 Oct 2007) New Revision: 2180 Modified: trunk/bknr/src/bknr-impex.asd trunk/bknr/src/bknr-utils.asd trunk/bknr/src/bknr.asd trunk/bknr/src/data/object.lisp trunk/bknr/src/data/package.lisp trunk/bknr/src/data/txn.lisp trunk/bknr/src/indices/package.lisp trunk/bknr/src/packages.lisp trunk/bknr/src/sysclasses/user.lisp trunk/bknr/src/utils/acl-mp-compat.lisp trunk/bknr/src/utils/package.lisp trunk/bknr/src/utils/utils.lisp trunk/bknr/src/utils/xml.lisp trunk/bknr/src/web/user-handlers.lisp trunk/bknr/src/web/user-tags.lisp trunk/bknr/src/web/web-visitor.lisp trunk/bknr/src/xml-impex/package.lisp Log: Merge back changes that I committed to the bos branch recently. This includes the SBCL compatibility fixes as well as the CXML fix from Kamen. Modified: trunk/bknr/src/bknr-impex.asd =================================================================== --- trunk/bknr/src/bknr-impex.asd 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/bknr-impex.asd 2007-10-04 07:41:40 UTC (rev 2180) @@ -21,7 +21,7 @@ :description "BKNR XML import/export" :long-description "" - :depends-on (:cl-interpol :cxml :bknr-utils :bknr-indices) + :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices) :components ((:module "xml-impex" :components Modified: trunk/bknr/src/bknr-utils.asd =================================================================== --- trunk/bknr/src/bknr-utils.asd 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/bknr-utils.asd 2007-10-04 07:41:40 UTC (rev 2180) @@ -17,7 +17,6 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cl-ppcre - :cxml :md5 #+(not allegro) :acl-compat @@ -37,7 +36,6 @@ (:file "base64" :depends-on ("utils")) (:file "capability" :depends-on ("utils")) (:file "make-fdf-file" :depends-on ("utils")) - (:file "xml" :depends-on ("utils")) (:file "date-calc") (:file "acl-mp-compat" :depends-on ("package")))))) Modified: trunk/bknr/src/bknr.asd =================================================================== --- trunk/bknr/src/bknr.asd 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/bknr.asd 2007-10-04 07:41:40 UTC (rev 2180) @@ -28,6 +28,7 @@ :cxml :unit-test :bknr-utils + :bknr-xml :puri ;:stem ;:mime Modified: trunk/bknr/src/data/object.lisp =================================================================== --- trunk/bknr/src/data/object.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/data/object.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -607,6 +607,34 @@ :timestamp (get-universal-time) :args (mapcar #'store-object-id objects))))) +(defgeneric cascade-delete-p (object referencing-object) + (:documentation "return non-nil if the REFERENCING-OBJECT should be deleted when the OBJECT is deleted")) + +(defmethod cascade-delete-p (object referencing-object) + nil) + +(defun partition-list (list predicate) + "Return two list values, the first containing all elements from LIST +that satisfy PREDICATE, the second those that don't" + (let (do dont) + (dolist (element list) + (if (funcall predicate element) + (push element do) + (push element dont))) + (values do dont))) + +(defun cascading-delete-object (object) + "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by +the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible +to cascading deletes." + (multiple-value-bind (cascading-delete-refs + remaining-refs) + (partition-list (find-refs object) #'cascade-delete-p) + (when remaining-refs + (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!" + object)) + (apply #'delete-objects object cascading-delete-refs))) + (deftransaction change-slot-values (object &rest slots-and-values) (when object (loop for (slot value) on slots-and-values by #'cddr @@ -655,4 +683,17 @@ (deftransaction store-object-set-keywords (object slot keywords) (setf (slot-value object slot) keywords)) +(defmethod find-refs ((object store-object)) + "Find references to the given OBJECT in all store-objects, traversing both single valued and list valued slots." + (remove-if-not + (lambda (candidate) + (find-if (lambda (slotd) + (and (slot-boundp candidate (slot-definition-name slotd)) + (let ((slot-value (slot-value candidate (slot-definition-name slotd)))) + (or (eq object slot-value) + (and (listp slot-value) + (find object slot-value)))))) + (class-slots (class-of candidate)))) + (class-instances 'store-object))) + (pushnew :mop-store cl:*features*) Modified: trunk/bknr/src/data/package.lisp =================================================================== --- trunk/bknr/src/data/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/data/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -52,6 +52,8 @@ #:delete-object #:delete-objects + #:cascade-delete-p + #:cascading-delete-object #:initialize-persistent-instance #:initialize-transient-instance @@ -108,4 +110,6 @@ #:store-blob-root-tempdir #:store-object-subsystem - #:blob-subsystem)) + #:blob-subsystem + + #:find-refs)) Modified: trunk/bknr/src/data/txn.lisp =================================================================== --- trunk/bknr/src/data/txn.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/data/txn.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -43,11 +43,11 @@ () (:default-initargs :guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk)))) :log-guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk))))) (:documentation "Store in which every transaction and operation is protected by a giant lock.")) Modified: trunk/bknr/src/indices/package.lisp =================================================================== --- trunk/bknr/src/indices/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/indices/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -6,7 +6,6 @@ #+cmu :ext #+sbcl :sb-ext :cl-user - :cxml :bknr.utils :bknr.skip-list #+allegro :aclmop Modified: trunk/bknr/src/packages.lisp =================================================================== --- trunk/bknr/src/packages.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/packages.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -26,7 +26,7 @@ #:start-cron)) (defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) + (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) (:export #:xml-escape #:*img-src-scanner* #:*a-href-scanner* @@ -130,6 +130,7 @@ #:user-flags #:user-preferences #:user-subscriptions + #:user-editable-p ;; Export slot names so that derived classes can overload ;; slots (e.g. to add XML impex attributes) @@ -152,6 +153,7 @@ #:user-add-flags #:user-remove-flags #:all-user-flags + #:define-user-flag #:user-reachable-by-mail-p #:user-mail-error-p @@ -163,6 +165,7 @@ #:all-users #:get-flag-users #:make-user + #:delete-user #:set-user-password #:set-user-last-login @@ -189,6 +192,7 @@ :bknr.indices :bknr.impex :bknr.utils + :bknr.xml :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) Modified: trunk/bknr/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/src/sysclasses/user.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/sysclasses/user.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -13,8 +13,7 @@ :index-values all-users) (flags :update :initform nil :index-type hash-list-index - :index-reader get-flag-users - :index-keys all-user-flags) + :index-reader get-flag-users) (email :update :initform "" :documentation "Email Address, must be unique") @@ -30,6 +29,15 @@ (defconstant +salt-length+ 8) +(defgeneric user-editable-p (user) + (:documentation "Return non-nil if the given user can be edited through the administration interface. The USER class +is frequently subclassed to implement special user accounts that are self-registered and that cannot be edited through +the standard user administration interface. It would be better if the ``real'' system users would live in a seperate base +class that would be editable and have the USER class be non-editable.")) + +(defmethod user-editable-p ((user user)) + t) + (defun make-salt () (coerce (loop for i from 1 upto +salt-length+ @@ -91,6 +99,14 @@ (defmethod user-has-flag ((user user) flag) (find flag (user-flags user))) +(defvar *user-flags* '(:admin)) + +(defun define-user-flag (keyword) + (pushnew keyword *user-flags*)) + +(defun all-user-flags () + (copy-list *user-flags*)) + (defmethod verify-password ((user user) password) (when password (let ((upw (user-password user))) @@ -149,6 +165,14 @@ (set-user-password user password)) user)) +(defmethod cascade-delete-p ((user user) (event event)) + t) + +(defmethod delete-user ((user user)) + (when (eq user (find-user "anonymous")) + (error "Can't delete system user ``anonymous''")) + (cascading-delete-object user)) + (deftransaction set-user-full-name (user full-name) (setf (user-full-name user) full-name)) @@ -215,4 +239,4 @@ (defmethod as-xml ((event message-event)) (generate-event-xml event :from (message-event-from-name event) - :text (message-event-text event))) \ No newline at end of file + :text (message-event-text event))) Modified: trunk/bknr/src/utils/acl-mp-compat.lisp =================================================================== --- trunk/bknr/src/utils/acl-mp-compat.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/acl-mp-compat.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -18,3 +18,14 @@ #+cmu `(mp:with-lock-held (,lock) ,@body)) + +(defmacro mp-with-recursive-lock-held ((lock) &rest body) + #+allegro + `(mp:with-process-lock (,lock) + ,@body) + #+sbcl + `(sb-thread:with-recursive-lock (,lock) + ,@body) + #+cmu + `(mp:with-lock-held (,lock) + ,@body)) Modified: trunk/bknr/src/utils/package.lisp =================================================================== --- trunk/bknr/src/utils/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -4,7 +4,6 @@ (:use :cl :cl-ppcre :cl-interpol - :cxml-xmls :md5 #+cmu :extensions ; #+sbcl :sb-ext @@ -122,15 +121,6 @@ #:string-beginning-with-p #:string-delimited-by-p - ;; xml - #:node-children-nodes - #:find-child - #:find-children - #:node-string-body - #:node-attribute - #:node-child-string-body - #:node-to-html - ;; crypt-md5 #:crypt-md5 #:verify-md5-password @@ -147,6 +137,10 @@ ;; mp compatibility #:mp-make-lock #:mp-with-lock-held + #:mp-with-recursive-lock-held ;; class utils - #:class-subclasses)) + #:class-subclasses + + ;; norvig + #:find-all)) Modified: trunk/bknr/src/utils/utils.lisp =================================================================== --- trunk/bknr/src/utils/utils.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/utils.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -545,4 +545,15 @@ (format nil "~3,1F KB" (/ byte-count 1024))) (t (format nil "~A" byte-count)))) - \ No newline at end of file + +;;; from norvig +(defun find-all (item sequence &rest keyword-args + &key (test #'eql) test-not &allow-other-keys) + "Find all those elements of sequence that match item, + according to the keywords. Doesn't alter sequence." + (if test-not + (apply #'remove item sequence + :test-not (complement test-not) keyword-args) + (apply #'remove item sequence + :test (complement test) keyword-args))) + Modified: trunk/bknr/src/utils/xml.lisp =================================================================== --- trunk/bknr/src/utils/xml.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/utils/xml.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -1,63 +0,0 @@ -(in-package :bknr.utils) - -(defun node-children-nodes (xml) - (remove-if-not #'consp (node-children xml))) - -(defun find-child (xml node-name) - (let ((children (node-children-nodes xml))) - (find node-name children :test #'string-equal :key #'node-name))) - -(defun find-children (xml node-name) - (let ((children (node-children-nodes xml))) - (find-all node-name children :test #'string-equal :key #'node-name))) - -(defun node-string-body (xml) - (let ((children (remove-if #'consp (node-children xml)))) - (if (every #'stringp children) - (apply #'concatenate 'string children) - (error "Some children are not strings")))) - -(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) - -(defun node-child-string-body (xml node-name) - (let ((child (find-child xml node-name))) - (if (and child (consp child)) - (node-string-body child) - nil))) - -(defun node-to-html (node &optional (stream *standard-output*)) - (when (stringp node) - (write-string node) - (return-from node-to-html)) - (write-char #\< stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (loop for (key value) in (node-attrs node) - do (write-char #\Space stream) - (write-string key stream) - (write-char #\= stream) - (write-char #\" stream) - (write-string value stream) - (write-char #\" stream)) - (if (node-children node) - (progn - (write-char #\> stream) - (write-char #\Newline stream) - (dolist (child (node-children node)) - (node-to-html child stream)) - (write-char #\< stream) - (write-char #\/ stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (write-char #\> stream) - (write-char #\Newline stream)) - (progn (write-char #\Space stream) - (write-char #\/ stream) - (write-char #\> stream) - (write-char #\Newline stream)))) - Modified: trunk/bknr/src/web/user-handlers.lisp =================================================================== --- trunk/bknr/src/web/user-handlers.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/web/user-handlers.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -59,13 +59,21 @@ (defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req) (with-bknr-page (req :title "Manage users") - #+(or) - (:ul (loop for user in (remove :registered (all-users) :key #'user-flags :test #'member) - do (html (:li ((:a :href (object-url user)) - (:princ-safe (user-login user))))))) - ((:form :method "POST") - (:h2 "Search for user") - "Login: " ((:input :type "text" :name "login" :size "20")) (submit-button "search" "search")) + ((:table :border "1") + (:tr (:th "Login") + (:th "Real name") + (:th "Privileges") + (:th "Last login")) + (dolist (user (sort (remove-if-not #'user-editable-p (all-users)) + #'string-lessp :key #'user-login)) + (html (:tr (:td ((:a :href (object-url user)) + (:princ-safe (user-login user)))) + (:td (:princ-safe (user-full-name user))) + (:td (:princ-safe (format nil "~{~A~^, ~}" (user-flags user)))) + (:td (:princ-safe (if (and (user-last-login user) + (plusp (user-last-login user))) + (format-date-time (user-last-login user)) + "<never logged in>"))))))) (:h2 "Create new user") (user-form))) @@ -90,25 +98,27 @@ (when password (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name))) + + (when (admin-p (bknr-request-user req)) + (let* ((all-flags (all-user-flags)) + (set-flags (keywords-from-query-param-list (query-param-list req "flags"))) + (unset-flags (set-difference all-flags set-flags))) + (user-add-flags user set-flags) + (user-remove-flags user unset-flags))) + (call-next-method)) +(define-condition unauthorized-error (simple-error) + () + (:report "You are not authorized to perform this operation")) + (defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req) + (unless (admin-p (bknr-request-user req)) + (error 'unauthorized-error)) (when user - (delete-object user)) + (delete-user user)) (redirect "/user" req)) -(defmethod handle-object-form ((handler user-handler) (action (eql :add-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-add-flags user flags))) - (call-next-method)) - -(defmethod handle-object-form ((handler user-handler) (action (eql :remove-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-remove-flags user flags))) - (call-next-method)) - (defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req) (with-query-params (req login email full-name password password-repeat) (if (and password @@ -116,14 +126,14 @@ (error "please enter the same password twice") (if login (let* ((flags (keywords-from-query-param-list (query-param-list req "keyword"))) - (user (make-object 'user :login login - :email email - :full-name full-name - :password password - :flags flags))) + (user (make-user login + :email email + :full-name full-name + :password password + :flags flags))) (redirect (edit-object-url user) req)) (error "please enter a login"))))) (define-bknr-webserver-module user ("/user" user-handler) - ("/logout" logout-handler)) \ No newline at end of file + ("/logout" logout-handler)) Modified: trunk/bknr/src/web/user-tags.lisp =================================================================== --- trunk/bknr/src/web/user-tags.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/web/user-tags.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -2,20 +2,15 @@ (enable-interpol-syntax) -(define-bknr-tag user-flag-choose-dialog (&key (size "4") (name "keyword") (create nil)) - (let ((size (or (parse-integer size :junk-allowed t) 1))) - (loop for i from 1 to size - do (html ((:div :class "keyword-choose") - (when (> size 1) - (html (:princ-safe i) ". ")) - (select-box name - (loop for flag in - (sort (all-user-flags) #'string<) - collect (list (string-downcase flag) flag))) - (when create - (html ((:input :type "text" :length "20" :name name))))))))) +(define-bknr-tag user-flag-choose-dialog (&key enabled) + (dolist (flag (sort (all-user-flags) #'string<)) + (html + ((:div :class "user-flag-choose") + (if (find flag enabled) + (html ((:input :type "checkbox" :name "flags" :value flag :checked "checked"))) + (html ((:input :type "checkbox" :name "flags" :value flag)))) + (:princ-safe flag))))) - (define-bknr-tag user-form (&key user-id) (let ((user (when user-id (store-object-with-id (if (numberp user-id) @@ -36,11 +31,7 @@ (:td (html (text-field "email" :value (user-email user))))) (when (admin-p *user*) (html (:tr (:td "flags") - (:td (dolist (flag (user-flags user)) - (html (:princ-safe flag) " ")))) - (:tr (:td "new flags") - (:td (user-flag-choose-dialog :create t - :size "2"))))) + (:td (user-flag-choose-dialog :enabled (user-flags user)))))) (:tr (:td "new password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat new password") @@ -48,9 +39,7 @@ (:tr ((:td :colspan "2") (submit-button "save" "save") (when (admin-p *user*) - (submit-button "add-flags" "add flags") - (submit-button "remove-flags" "remove flags") - (submit-button "delete" "delete"))))))) + (submit-button "delete" "delete" :confirm "Really delete this user account? The operation cannot be undone."))))))) (html ((:form :method "post") (:table (:tr (:td "login") @@ -60,7 +49,7 @@ (:tr (:td "email") (:td ((:input :type "text" :name "email" :size "40")))) (:tr (:td "flags") - (:td (user-flag-choose-dialog :create t :size "2"))) + (:td (user-flag-choose-dialog))) (:tr (:td "password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat password") Modified: trunk/bknr/src/web/web-visitor.lisp =================================================================== --- trunk/bknr/src/web/web-visitor.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/web/web-visitor.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -16,12 +16,15 @@ (host-ip-address (web-visitor-event-host event)))) (defmethod print-object ((event web-visitor-event) stream) - (format stream "#<~a at ~a user ~a from ~a [~a]>" - (class-of event) (format-date-time (event-time event)) - (when (web-visitor-event-user event) - (user-login (web-visitor-event-user event))) - (host-name (web-visitor-event-host event)) - (host-ip-address (web-visitor-event-host event))) + (print-unreadable-object (event stream :type t :identity t) + (format stream "at ~A user ~A" + (format-date-time (event-time event)) + (and (web-visitor-event-user event) + (user-login (web-visitor-event-user event)))) + (when (web-visitor-event-host event) + (format stream " from ~a [~a]" + (host-name (web-visitor-event-host event)) + (host-ip-address (web-visitor-event-host event)))))) event) #+(or) Modified: trunk/bknr/src/xml-impex/package.lisp =================================================================== --- trunk/bknr/src/xml-impex/package.lisp 2007-10-04 07:23:42 UTC (rev 2179) +++ trunk/bknr/src/xml-impex/package.lisp 2007-10-04 07:41:40 UTC (rev 2180) @@ -13,6 +13,7 @@ #+sbcl :sb-pcl :bknr.utils + :bknr.xml :bknr.indices) (:export #:xml-class

1 0

[bknr-cvs] r2179 - branches/bos/thirdparty/asdf
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 03:23:42 -0400 (Thu, 04 Oct 2007) New Revision: 2179 Modified: branches/bos/thirdparty/asdf/asdf.lisp Log: Update asdf to current cclan version. Modified: branches/bos/thirdparty/asdf/asdf.lisp =================================================================== --- branches/bos/thirdparty/asdf/asdf.lisp 2007-10-03 01:20:42 UTC (rev 2178) +++ branches/bos/thirdparty/asdf/asdf.lisp 2007-10-04 07:23:42 UTC (rev 2179) @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.110 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list(a)lists.sf.net>. But note first that the canonical @@ -13,7 +13,7 @@ ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' -;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; Copyright (c) 2001-2007 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -78,7 +78,10 @@ #:system-author #:system-maintainer #:system-license - + #:system-licence + #:system-source-file + #:system-relative-pathname + #:operation-on-warnings #:operation-on-failure @@ -90,24 +93,29 @@ #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors - + #:duplicate-names + #:retry #:accept ; restarts + #:preference-file-for-system/operation + #:load-preferences ) (:use :cl)) + #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.110 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -117,10 +125,14 @@ :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) + (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) +(defparameter +asdf-methods+ + '(perform explain output-files operation-done-p)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff @@ -156,6 +168,9 @@ (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) @@ -168,7 +183,7 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s (formatter "~@<erred while invoking ~A on ~A~@:>") + (format s "~@<erred while invoking ~A on ~A~@:>" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -199,9 +214,8 @@ ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s (formatter "~@<~A, required by ~A~@:>") - (call-next-method c nil) - (missing-required-by c))) + (format s "~@<~A, required by ~A~@:>" + (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) @@ -209,9 +223,9 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s (formatter "~@<component ~S not found~ - ~@[ or does not match version ~A~]~ - ~@[ in ~A~]~@:>") + (format s "~@<component ~S not found~ + ~@[ or does not match version ~A~]~ + ~@[ in ~A~]~@:>" (missing-requires c) (missing-version c) (when (missing-parent c) @@ -281,7 +295,8 @@ :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence))) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license))) ;;; version-satisfies @@ -326,8 +341,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error (formatter "~@<invalid component designator ~A~@:>") - name)))) + (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- @@ -356,6 +370,14 @@ (if (and file (probe-file file)) (return file))))))) +(defun make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) @@ -364,15 +386,18 @@ (when (and on-disk (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) - (let ((*package* (make-package (gensym (package-name #.*package*)) - :use '(:cl :asdf)))) - (format *verbose-out* - (formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%") - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. + (let ((package (make-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. on-disk *package*) - (load on-disk))) + (load on-disk)) + (delete-package package)))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) @@ -380,8 +405,7 @@ (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) - (format *verbose-out* - (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name) + (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) @@ -427,17 +451,20 @@ (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) - (let* ((*default-pathname-defaults* (component-parent-pathname component)) - (name-type - (make-pathname - :name (component-name component) - :type (source-file-type component - (component-system component))))) - (if (slot-value component 'relative-pathname) - (merge-pathnames - (slot-value component 'relative-pathname) - name-type) - name-type))) + (let ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + name-type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -537,8 +564,26 @@ (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) -(defgeneric component-depends-on (operation component)) +(defgeneric component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + (<operation> <component>*), where <operation> is a class + designator and each <component> is a component + designator, which means that the component depends on + <operation> having been performed on each <component>; or + + (FEATURE <feature>), which means that the component depends + on <feature>'s presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defmethod component-depends-on ((op-spec symbol) (c component)) + (component-depends-on (make-instance op-spec) c)) + (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) (slot-value c 'in-order-to)))) @@ -567,26 +612,40 @@ (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) - (let ((out-files (output-files o c)) - (in-files (input-files o c))) - (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (or (apply #'max - (mapcar #'file-write-date in-files)) 0))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'file-write-date in-files)) )))))) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~ + operation ~S on component ~S as done.~@:>" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination @@ -676,16 +735,15 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - (formatter "~@<required method PERFORM not implemented~ - for operation ~A, component ~A~@:>") + "~@<required method PERFORM not implemented ~ + for operation ~A, component ~A~@:>" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) nil) (defmethod explain ((operation operation) (component component)) - (format *verbose-out* "~&;;; ~A on ~A~%" - operation component)) + (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) ;;; compile-op @@ -701,38 +759,39 @@ (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 - (formatter "~@<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 - (formatter "~@<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)) - (list (compile-file-pathname (component-pathname c)))) + #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #+:broken-fasl-loader (list (component-pathname c))) (defmethod perform ((operation compile-op) (c static-file)) nil) @@ -740,10 +799,16 @@ (defmethod output-files ((operation compile-op) (c static-file)) nil) +(defmethod input-files ((op compile-op) (c static-file)) + nil) + + ;;; 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))) @@ -761,7 +826,7 @@ ;;; 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))) @@ -796,46 +861,103 @@ (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)) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil + :defaults *default-pathname-defaults*))) + (merge-pathnames + (make-pathname :name (component-name s) + :type "lisp" + :directory '(:relative ".asdf")) + (truename (user-homedir-pathname))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations -(defun operate (operation-class system &rest args) +(defvar *operate-docstring* + "Operate does three things: + +1. It creates an instance of `operation-class` using any keyword parameters +as initargs. +2. It finds the asdf-system specified by `system` (possibly loading +it from disk). +3. It then calls `traverse` with the operation and system as arguments + +The traverse operation is wrapped in `with-compilation-unit` and error +handling code. If a `version` argument is supplied, then operate also +ensures that the system found satisfies it using the `version-satisfies` +method.") + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (steps (traverse op system))) - (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s - (formatter "~@<Retry performing ~S on ~S.~@:>") - op component))) - (accept () - :report - (lambda (s) - (format s - (formatter "~@<Continue, treating ~S on ~S as ~ - having been successful.~@:>") - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) + :original-initargs args + args)) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@<Retry performing ~S on ~S.~@:>" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@<Continue, treating ~S on ~S as ~ + having been successful.~@:>" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) -(defun oos (&rest args) - "Alias of OPERATE function" - (apply #'operate args)) +(setf (documentation 'operate 'function) + *operate-docstring*) +(defun oos (operation-class system &rest args &key force (verbose t) version) + (declare (ignore force verbose version)) + (apply #'operate operation-class system args)) + +(setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a" + *operate-docstring*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax @@ -871,22 +993,30 @@ :module (coerce-name ',name) :pathname (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) + (when *load-truename* + (pathname-sans-name+type + (resolve-symlinks *load-truename*))) *default-pathname-defaults*) ',component-options)))))) (defun class-for-type (parent type) - (let ((class (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.*package*)) nil))) + (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) + (load-time-value + (package-name :asdf))))) + (class (dolist (symbol (if (keywordp type) + extra-symbols + (cons type extra-symbols))) + (when (and symbol + (find-class symbol nil) + (subtypep symbol 'component)) + (return (find-class symbol)))))) (or class (and (eq type :file) (or (module-default-component-class parent) (find-class 'cl-source-file))) - (sysdef-error (formatter "~@<don't recognize component type ~A~@:>") - type)))) + (sysdef-error "~@<don't recognize component type ~A~@:>" type)))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -923,27 +1053,42 @@ (defvar *serial-depends-on*) (defun parse-component-form (parent options) + (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to ;; list ends &allow-other-keys) options - (check-component-input type name depends-on components in-order-to) + (declare (ignorable perform explain output-files operation-done-p)) + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) rest)) (ret (or (find-component parent name) (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) (when (boundp '*serial-depends-on*) (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) + (concatenate 'list *serial-depends-on* depends-on))) (apply #'reinitialize-instance ret :name (coerce-name name) @@ -961,7 +1106,19 @@ for c = (parse-component-form ret c-form) collect c if serial - do (push (component-name c) *serial-depends-on*))))) + do (push (component-name c) *serial-depends-on*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) (setf (slot-value ret 'in-order-to) (union-of-dependencies @@ -970,28 +1127,39 @@ (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) (remove-method (symbol-function n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret)))) + (%remove-component-inline-methods ret rest) + ret))) -(defun check-component-input (type name depends-on components in-order-to) +(defun %remove-component-inline-methods (ret rest) + (loop for name in +asdf-methods+ + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods ret))) + ;; clear methods, then add the new ones + (setf (component-inline-methods ret) nil) + (loop for name in +asdf-methods+ + for v = (getf rest (intern (symbol-name name) :keyword)) + when v do + (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." type name components)) @@ -1018,14 +1186,15 @@ (defun run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with -output to *verbose-out*. Returns the shell's exit code." +output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (format *verbose-out* "; $ ~A~%" command) #+sbcl - (sb-impl::process-exit-code + (sb-ext:process-exit-code (sb-ext:run-program - "/bin/sh" + #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) + #+win32 #+win32 :search t :input nil :output *verbose-out*)) #+(or cmu scl) @@ -1053,8 +1222,9 @@ (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out* :wait t))) - - #-(or openmcl clisp lispworks allegro scl cmu sbcl) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) @@ -1066,7 +1236,29 @@ (defun hyperdoc (name doc-type) (hyperdocumentation (symbol-package name) name doc-type)) +(defun system-source-file (system-name) + (let ((system (asdf:find-system system-name))) + (make-pathname + :type "asd" + :name (asdf:component-name system) + :defaults (asdf:component-relative-pathname system)))) +(defun system-source-directory (system-name) + (make-pathname :name nil + :type nil + :defaults (system-source-file system-name))) + +(defun system-relative-pathname (system pathname &key name type) + (let ((directory (pathname-directory pathname))) + (when (eq (car directory) :absolute) + (setf (car directory) :relative)) + (merge-pathnames + (make-pathname :name (or name (pathname-name pathname)) + :type (or type (pathname-type pathname)) + :directory directory) + (system-source-directory system)))) + + (pushnew :asdf *features*) #+sbcl @@ -1084,14 +1276,24 @@ (asdf:operate 'asdf:load-op name) t)))) - (pushnew - '(merge-pathnames "systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - *central-registry*) + (defun contrib-sysdef-search (system) + (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (let* ((name (coerce-name system)) + (home (truename home)) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))))) (pushnew - '(merge-pathnames "site-systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) + '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (merge-pathnames "site-systems/" (truename home)))) *central-registry*) (pushnew @@ -1099,6 +1301,8 @@ (user-homedir-pathname)) *central-registry*) - (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) (provide 'asdf) +

1 0

[bknr-cvs] r2178 - in branches/bos: bknr/src bknr/src/indices bknr/src/utils bknr/src/xml bknr/src/xml-impex projects/bos/worldpay-test thirdparty/ironclad
by bknr＠bknr.net 03 Oct '07

03 Oct '07

Author: hhubner Date: 2007-10-02 21:20:42 -0400 (Tue, 02 Oct 2007) New Revision: 2178 Added: branches/bos/bknr/src/bknr-xml.asd branches/bos/bknr/src/xml/ branches/bos/bknr/src/xml/package.lisp branches/bos/bknr/src/xml/xml.lisp Removed: branches/bos/thirdparty/ironclad/digest.lisp.orig branches/bos/thirdparty/ironclad/package.lisp.orig Modified: branches/bos/bknr/src/bknr-impex.asd branches/bos/bknr/src/bknr-utils.asd branches/bos/bknr/src/bknr.asd branches/bos/bknr/src/indices/package.lisp branches/bos/bknr/src/packages.lisp branches/bos/bknr/src/utils/package.lisp branches/bos/bknr/src/utils/utils.lisp branches/bos/bknr/src/utils/xml.lisp branches/bos/bknr/src/xml-impex/package.lisp branches/bos/projects/bos/worldpay-test/utils.lisp Log: Patch from Kamen Tomov to isolate CXML from the datastore. In order to get this compiled, I moved FIND-ALL from the BOS project to bknr/src/utils. Modified: branches/bos/bknr/src/bknr-impex.asd =================================================================== --- branches/bos/bknr/src/bknr-impex.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr-impex.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -21,7 +21,7 @@ :description "BKNR XML import/export" :long-description "" - :depends-on (:cl-interpol :cxml :bknr-utils :bknr-indices) + :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices) :components ((:module "xml-impex" :components Modified: branches/bos/bknr/src/bknr-utils.asd =================================================================== --- branches/bos/bknr/src/bknr-utils.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr-utils.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -17,7 +17,6 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cl-ppcre - :cxml :md5 #+(not allegro) :acl-compat @@ -37,7 +36,6 @@ (:file "base64" :depends-on ("utils")) (:file "capability" :depends-on ("utils")) (:file "make-fdf-file" :depends-on ("utils")) - (:file "xml" :depends-on ("utils")) (:file "date-calc") (:file "acl-mp-compat" :depends-on ("package")))))) Added: branches/bos/bknr/src/bknr-xml.asd =================================================================== --- branches/bos/bknr/src/bknr-xml.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr-xml.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -0,0 +1,42 @@ +;; -*-Lisp-*- + +(in-package :cl-user) + +(defpackage :bknr.xml.system + (:use :cl :asdf)) + +(in-package :bknr.xml.system) + +(defsystem :bknr-xml + :name "baikonour" + :author "Hans Huebner <hans(a)huebner.org>" + :author "Manuel Odendahl <manuel(a)bl0rg.net>" + :version "0" + :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" + :licence "BSD" + :description "baikonour - launchpad for lisp satellites" + :depends-on (:cl-interpol :cxml) + :components ((:module "xml" :components ((:file "package") + (:file "xml"))))) + +;; -*-Lisp-*- + +(in-package :cl-user) + +(defpackage :bknr.xml.system + (:use :cl :asdf)) + +(in-package :bknr.xml.system) + +(defsystem :bknr-xml + :name "baikonour" + :author "Hans Huebner <hans(a)huebner.org>" + :author "Manuel Odendahl <manuel(a)bl0rg.net>" + :version "0" + :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" + :licence "BSD" + :description "baikonour - launchpad for lisp satellites" + :depends-on (:cl-interpol :cxml) + :components ((:module "xml" :components ((:file "package") + (:file "xml"))))) + Modified: branches/bos/bknr/src/bknr.asd =================================================================== --- branches/bos/bknr/src/bknr.asd 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/bknr.asd 2007-10-03 01:20:42 UTC (rev 2178) @@ -28,6 +28,7 @@ :cxml :unit-test :bknr-utils + :bknr-xml :puri ;:stem ;:mime Modified: branches/bos/bknr/src/indices/package.lisp =================================================================== --- branches/bos/bknr/src/indices/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/indices/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -6,7 +6,6 @@ #+cmu :ext #+sbcl :sb-ext :cl-user - :cxml :bknr.utils :bknr.skip-list #+allegro :aclmop Modified: branches/bos/bknr/src/packages.lisp =================================================================== --- branches/bos/bknr/src/packages.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/packages.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -26,7 +26,7 @@ #:start-cron)) (defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) + (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) (:export #:xml-escape #:*img-src-scanner* #:*a-href-scanner* @@ -192,6 +192,7 @@ :bknr.indices :bknr.impex :bknr.utils + :bknr.xml :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) Modified: branches/bos/bknr/src/utils/package.lisp =================================================================== --- branches/bos/bknr/src/utils/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/utils/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -4,7 +4,6 @@ (:use :cl :cl-ppcre :cl-interpol - :cxml-xmls :md5 #+cmu :extensions ; #+sbcl :sb-ext @@ -122,15 +121,6 @@ #:string-beginning-with-p #:string-delimited-by-p - ;; xml - #:node-children-nodes - #:find-child - #:find-children - #:node-string-body - #:node-attribute - #:node-child-string-body - #:node-to-html - ;; crypt-md5 #:crypt-md5 #:verify-md5-password @@ -150,4 +140,7 @@ #:mp-with-recursive-lock-held ;; class utils - #:class-subclasses)) + #:class-subclasses + + ;; norvig + #:find-all)) Modified: branches/bos/bknr/src/utils/utils.lisp =================================================================== --- branches/bos/bknr/src/utils/utils.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/utils/utils.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -545,4 +545,15 @@ (format nil "~3,1F KB" (/ byte-count 1024))) (t (format nil "~A" byte-count)))) - \ No newline at end of file + +;;; from norvig +(defun find-all (item sequence &rest keyword-args + &key (test #'eql) test-not &allow-other-keys) + "Find all those elements of sequence that match item, + according to the keywords. Doesn't alter sequence." + (if test-not + (apply #'remove item sequence + :test-not (complement test-not) keyword-args) + (apply #'remove item sequence + :test (complement test) keyword-args))) + Modified: branches/bos/bknr/src/utils/xml.lisp =================================================================== --- branches/bos/bknr/src/utils/xml.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/utils/xml.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -1,63 +0,0 @@ -(in-package :bknr.utils) - -(defun node-children-nodes (xml) - (remove-if-not #'consp (node-children xml))) - -(defun find-child (xml node-name) - (let ((children (node-children-nodes xml))) - (find node-name children :test #'string-equal :key #'node-name))) - -(defun find-children (xml node-name) - (let ((children (node-children-nodes xml))) - (find-all node-name children :test #'string-equal :key #'node-name))) - -(defun node-string-body (xml) - (let ((children (remove-if #'consp (node-children xml)))) - (if (every #'stringp children) - (apply #'concatenate 'string children) - (error "Some children are not strings")))) - -(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) - -(defun node-child-string-body (xml node-name) - (let ((child (find-child xml node-name))) - (if (and child (consp child)) - (node-string-body child) - nil))) - -(defun node-to-html (node &optional (stream *standard-output*)) - (when (stringp node) - (write-string node) - (return-from node-to-html)) - (write-char #\< stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (loop for (key value) in (node-attrs node) - do (write-char #\Space stream) - (write-string key stream) - (write-char #\= stream) - (write-char #\" stream) - (write-string value stream) - (write-char #\" stream)) - (if (node-children node) - (progn - (write-char #\> stream) - (write-char #\Newline stream) - (dolist (child (node-children node)) - (node-to-html child stream)) - (write-char #\< stream) - (write-char #\/ stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (write-char #\> stream) - (write-char #\Newline stream)) - (progn (write-char #\Space stream) - (write-char #\/ stream) - (write-char #\> stream) - (write-char #\Newline stream)))) - Added: branches/bos/bknr/src/xml/package.lisp =================================================================== --- branches/bos/bknr/src/xml/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/xml/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -0,0 +1,16 @@ +(in-package :cl-user) + +(defpackage :bknr.xml + (:use :cl + :cl-ppcre + :cl-interpol + :cxml-xmls) + (:shadowing-import-from :cl-interpol "QUOTE-META-CHARS") + (:export + #:node-children-nodes + #:find-child + #:find-children + #:node-string-body + #:node-attribute + #:node-child-string-body + #:node-to-html)) Added: branches/bos/bknr/src/xml/xml.lisp =================================================================== --- branches/bos/bknr/src/xml/xml.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/xml/xml.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -0,0 +1,126 @@ +(in-package :bknr.xml) + +(defun node-children-nodes (xml) + (remove-if-not #'consp (node-children xml))) + +(defun find-child (xml node-name) + (let ((children (node-children-nodes xml))) + (find node-name children :test #'string-equal :key #'node-name))) + +(defun find-children (xml node-name) + (let ((children (node-children-nodes xml))) + (find-all node-name children :test #'string-equal :key #'node-name))) + +(defun node-string-body (xml) + (let ((children (remove-if #'consp (node-children xml)))) + (if (every #'stringp children) + (apply #'concatenate 'string children) + (error "Some children are not strings")))) + +(defun node-attribute (xml attribute-name) + (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) + +(defun node-child-string-body (xml node-name) + (let ((child (find-child xml node-name))) + (if (and child (consp child)) + (node-string-body child) + nil))) + +(defun node-to-html (node &optional (stream *standard-output*)) + (when (stringp node) + (write-string node) + (return-from node-to-html)) + (write-char #\< stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (loop for (key value) in (node-attrs node) + do (write-char #\Space stream) + (write-string key stream) + (write-char #\= stream) + (write-char #\" stream) + (write-string value stream) + (write-char #\" stream)) + (if (node-children node) + (progn + (write-char #\> stream) + (write-char #\Newline stream) + (dolist (child (node-children node)) + (node-to-html child stream)) + (write-char #\< stream) + (write-char #\/ stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (write-char #\> stream) + (write-char #\Newline stream)) + (progn (write-char #\Space stream) + (write-char #\/ stream) + (write-char #\> stream) + (write-char #\Newline stream)))) + +(in-package :bknr.xml) + +(defun node-children-nodes (xml) + (remove-if-not #'consp (node-children xml))) + +(defun find-child (xml node-name) + (let ((children (node-children-nodes xml))) + (find node-name children :test #'string-equal :key #'node-name))) + +(defun find-children (xml node-name) + (let ((children (node-children-nodes xml))) + (find-all node-name children :test #'string-equal :key #'node-name))) + +(defun node-string-body (xml) + (let ((children (remove-if #'consp (node-children xml)))) + (if (every #'stringp children) + (apply #'concatenate 'string children) + (error "Some children are not strings")))) + +(defun node-attribute (xml attribute-name) + (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) + +(defun node-child-string-body (xml node-name) + (let ((child (find-child xml node-name))) + (if (and child (consp child)) + (node-string-body child) + nil))) + +(defun node-to-html (node &optional (stream *standard-output*)) + (when (stringp node) + (write-string node) + (return-from node-to-html)) + (write-char #\< stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (loop for (key value) in (node-attrs node) + do (write-char #\Space stream) + (write-string key stream) + (write-char #\= stream) + (write-char #\" stream) + (write-string value stream) + (write-char #\" stream)) + (if (node-children node) + (progn + (write-char #\> stream) + (write-char #\Newline stream) + (dolist (child (node-children node)) + (node-to-html child stream)) + (write-char #\< stream) + (write-char #\/ stream) + (when (node-ns node) + (write-string (node-ns node) stream) + (write-char #\: stream)) + (write-string (node-name node) stream) + (write-char #\> stream) + (write-char #\Newline stream)) + (progn (write-char #\Space stream) + (write-char #\/ stream) + (write-char #\> stream) + (write-char #\Newline stream)))) + Modified: branches/bos/bknr/src/xml-impex/package.lisp =================================================================== --- branches/bos/bknr/src/xml-impex/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/bknr/src/xml-impex/package.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -13,6 +13,7 @@ #+sbcl :sb-pcl :bknr.utils + :bknr.xml :bknr.indices) (:export #:xml-class Modified: branches/bos/projects/bos/worldpay-test/utils.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/utils.lisp 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/projects/bos/worldpay-test/utils.lisp 2007-10-03 01:20:42 UTC (rev 2178) @@ -260,17 +260,6 @@ ((funcall test i num) (append l (nreverse smaller))))) -;;; from norvig -(defun find-all (item sequence &rest keyword-args - &key (test #'eql) test-not &allow-other-keys) - "Find all those elements of sequence that match item, - according to the keywords. Doesn't alter sequence." - (if test-not - (apply #'remove item sequence - :test-not (complement test-not) keyword-args) - (apply #'remove item sequence - :test (complement test) keyword-args))) - ;;; hash table (defun hash-to-list (hash &key (key #'cdr) (compare #'>) num) (let ((results (sort (loop for key being the hash-key of hash using (hash-value val) Deleted: branches/bos/thirdparty/ironclad/digest.lisp.orig =================================================================== --- branches/bos/thirdparty/ironclad/digest.lisp.orig 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/thirdparty/ironclad/digest.lisp.orig 2007-10-03 01:20:42 UTC (rev 2178) @@ -1,196 +0,0 @@ -;;;; digest.lisp -- common functions for hashing - -(in-package :crypto) - - -;;; defining digest (hash) functions - -;;; general inlinable functions for implementing the higher-level functions - -(declaim (inline digest-sequence-body digest-stream-body digest-file-body)) - -(defun digest-sequence-body (sequence state-creation-fn - state-update-fn - state-finalize-fn - &key (start 0) end) - (declare (type (vector (unsigned-byte 8)) sequence) (type index start)) - (let ((state (funcall state-creation-fn))) - #+cmu - (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) - (funcall state-update-fn state data - :start real-start :end (or real-end (length sequence)))) - #+sbcl - (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) - (funcall state-update-fn state data - :start real-start :end (or real-end (length sequence)))) - #-(or cmu sbcl) - (let ((real-end (or end (length sequence)))) - (declare (type index real-end)) - (funcall state-update-fn state sequence - :start start :end (or real-end (length sequence)))) - (funcall state-finalize-fn state))) - -(eval-when (:compile-toplevel) -(defconstant +buffer-size+ (* 128 1024)) -) ; EVAL-WHEN - -(deftype buffer-index () `(integer 0 (,+buffer-size+))) - -(defun digest-stream-body (stream state-creation-fn - state-update-fn - state-finalize-fn) - (let ((state (funcall state-creation-fn))) - (cond - ((equal (stream-element-type stream) '(unsigned-byte 8)) - (let ((buffer (make-array +buffer-size+ - :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) - buffer)) - (declare (dynamic-extent buffer)) - (loop for n-bytes of-type buffer-index = (read-sequence buffer stream) - do (funcall state-update-fn state buffer :end n-bytes) - until (< n-bytes +buffer-size+) - finally (return (funcall state-finalize-fn state))))) - (t - (error "Unsupported stream element-type ~S for stream ~S." - (stream-element-type stream) stream))))) - -(defun digest-file-body (pathname state-creation-fn - state-update-fn - state-finalize-fn) - (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :direction :input - :if-does-not-exist :error) - (digest-stream-body stream state-creation-fn state-update-fn - state-finalize-fn))) - - -;;; high-level generic function drivers - -;;; These three functions are intended to be one-shot ways to digest -;;; an object of some kind. You could write these in terms of the more -;;; familiar digest interface below, but these are likely to be slightly -;;; more efficient, as well as more obvious about what you're trying to -;;; do. -(defgeneric digest-file (digest-name pathname) - (:documentation "Return the digest of PATHNAME using the algorithm DIGEST-NAME.")) - -(defgeneric digest-stream (digest-name stream) - (:documentation "Return the digest of STREAM using the algorithm DIGEST-NAME. -STREAM-ELEMENT-TYPE of STREAM should be (UNSIGNED-BYTE 8).")) - -(defgeneric digest-sequence (digest-name sequence &key start end) - (:documentation "Return the digest of the subsequence of SEQUENCE -specified by START and END using the algorithm DIGEST-NAME. For CMUCL -and SBCL, SEQUENCE can be any vector with an element-type of -(UNSIGNED-BYTE 8); for other implementations, SEQUENCE must be a -SIMPLE-ARRAY.")) - -;;; These four functions represent the common interface for digests in -;;; other crypto toolkits (OpenSSL, Botan, Python, etc.). You obtain -;;; some state object for a particular digest, you update it with some -;;; data, and then you get the actual digest. Flexibility is the name -;;; of the game with these functions. -(defgeneric make-digest (digest-name) - (:documentation "Return a digest object which uses the algorithm DIGEST-NAME.")) - -(defgeneric copy-digest (digest) - (:documentation "Return a copy of DIGEST. The copy is a deep copy, not a -shallow copy as might be returned by COPY-STRUCTURE.")) - -(defgeneric update-digest (digest sequence &key start end) - (:documentation "Update the internal state of DIGEST with the subsequence -of SEQUENCE specified by START and END. For CMUCL and SBCL, SEQUENCE -can be any vector with an element-type of (UNSIGNED-BYTE 8); for other -implementations, SEQUENCE must be a SIMPLE-ARRAY.")) - -(defgeneric produce-digest (digest) - (:documentation "Return the hash of the data processed by DIGEST so far. -This function does not modify the internal state of DIGEST.")) - - -;;; the digest-defining macro - -(defvar *supported-digests* nil) - -(defun list-all-digests () - (copy-seq *supported-digests*)) - -(defun digest-supported-p (name) - "Return T if the digest NAME is a valid digest name." - (member name *supported-digests*)) - -(defgeneric digest-length (digest) - (:documentation "Return the number of bytes in a digest generated by DIGEST.")) - -(defmacro defdigest (name &rest initargs) - (%defdigest name initargs)) - -(defun %defdigest (name initargs) - (let ((creation-function nil) - (copy-function nil) - (update-function nil) - (finalize-function nil) - (state-type nil) - (digest-length nil) - (digest-name (intern (string name) (find-package :keyword)))) - (loop for (arg value) in initargs - do - (case arg - (:creation-function - (if (not creation-function) - (setf creation-function value) - (error "Specified :CREATION-FUNCTION multiple times."))) - (:copy-function - (if (not copy-function) - (setf copy-function value) - (error "Specified :COPY-FUNCTION multiple times."))) - (:update-function - (if (not update-function) - (setf update-function value) - (error "Specified :UPDATE-FUNCTION multiple times."))) - (:finalize-function - (if (not finalize-function) - (setf finalize-function value) - (error "Specified :FINALIZE-FUNCTION multiple times."))) - (:state-type - (if (not state-type) - (setf state-type value) - (error "Specified :STATE-TYPE multiple times."))) - (:digest-length - (if (not digest-length) - (setf digest-length value) - (error "Specified :DIGEST-LENGTH multiple times.")))) - finally (if (and creation-function copy-function update-function - finalize-function state-type digest-length) - (return (generate-digest-forms digest-name state-type - digest-length - creation-function - copy-function update-function - finalize-function)) - (error "Didn't specify all required options for DEFDIGEST"))))) - -(defun generate-digest-forms (digest-name state-type digest-length - creation-function copy-function - update-function finalize-function) - `(progn - (push ,digest-name *supported-digests*) - (defmethod digest-length ((digest (eql ,digest-name))) - ,digest-length) - (defmethod digest-length ((digest ,state-type)) - ,digest-length) - (defmethod make-digest ((digest-name (eql ,digest-name))) - (,creation-function)) - (defmethod copy-digest ((digest ,state-type)) - (,copy-function digest)) - (defmethod update-digest ((digest ,state-type) sequence &key (start 0) end) - (,update-function digest sequence - :start start :end (or end (length sequence)))) - (defmethod produce-digest ((digest ,state-type)) - (,finalize-function (,copy-function digest))) - (defmethod digest-file ((digest-name (eql ,digest-name)) pathname) - (digest-file-body pathname #',creation-function #',update-function #',finalize-function)) - (defmethod digest-stream ((digest-name (eql ,digest-name)) stream) - (digest-stream-body stream #',creation-function #',update-function #',finalize-function)) - (defmethod digest-sequence ((digest-name (eql ,digest-name)) sequence &key (start 0) end) - (digest-sequence-body sequence #',creation-function #',update-function #',finalize-function :start start :end end)))) Deleted: branches/bos/thirdparty/ironclad/package.lisp.orig =================================================================== --- branches/bos/thirdparty/ironclad/package.lisp.orig 2007-10-02 10:54:15 UTC (rev 2177) +++ branches/bos/thirdparty/ironclad/package.lisp.orig 2007-10-03 01:20:42 UTC (rev 2178) @@ -1,28 +0,0 @@ -(defpackage :ironclad - (:use :cl) - (:nicknames :crypto) - (:export - ;; hash functions - #:digest-sequence #:digest-stream #:digest-file - #:make-digest #:copy-digest #:update-digest #:produce-digest - - ;; HMACs - #:make-hmac #:update-hmac #:hmac-digest - - ;; introspection - #:cipher-supported-p #:list-all-ciphers - #:digest-supported-p #:list-all-digests - #:mode-supported-p #:list-all-modes - #:block-length #:digest-length - - ;; high-level operators - #:make-cipher #:encrypt #:decrypt - - ;; classes - #:aes-context #:square-context #:blowfish-context #:idea-context - #:twofish-context - #:des-context #:cast5-context #:tea-context #:xtea-context - - ;; conditions - #:ironclad-error #:initialization-vector-not-supplied - #:invalid-initialization-vector #:invalid-key-length)) \ No newline at end of file

1 0

[bknr-cvs] r2177 - in branches/bos/bknr/src: data utils
by bknr＠bknr.net 02 Oct '07

02 Oct '07

Author: hhubner Date: 2007-10-02 06:54:15 -0400 (Tue, 02 Oct 2007) New Revision: 2177 Modified: branches/bos/bknr/src/data/txn.lisp branches/bos/bknr/src/utils/acl-mp-compat.lisp branches/bos/bknr/src/utils/package.lisp Log: SBCL compatibility patch contributed by oudeis Modified: branches/bos/bknr/src/data/txn.lisp =================================================================== --- branches/bos/bknr/src/data/txn.lisp 2007-10-02 10:53:43 UTC (rev 2176) +++ branches/bos/bknr/src/data/txn.lisp 2007-10-02 10:54:15 UTC (rev 2177) @@ -43,11 +43,11 @@ () (:default-initargs :guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk)))) :log-guard (let ((lock (make-process-lock))) (lambda (thunk) - (mp-with-lock-held (lock) + (mp-with-recursive-lock-held (lock) (funcall thunk))))) (:documentation "Store in which every transaction and operation is protected by a giant lock.")) Modified: branches/bos/bknr/src/utils/acl-mp-compat.lisp =================================================================== --- branches/bos/bknr/src/utils/acl-mp-compat.lisp 2007-10-02 10:53:43 UTC (rev 2176) +++ branches/bos/bknr/src/utils/acl-mp-compat.lisp 2007-10-02 10:54:15 UTC (rev 2177) @@ -18,3 +18,14 @@ #+cmu `(mp:with-lock-held (,lock) ,@body)) + +(defmacro mp-with-recursive-lock-held ((lock) &rest body) + #+allegro + `(mp:with-process-lock (,lock) + ,@body) + #+sbcl + `(sb-thread:with-recursive-lock (,lock) + ,@body) + #+cmu + `(mp:with-lock-held (,lock) + ,@body)) Modified: branches/bos/bknr/src/utils/package.lisp =================================================================== --- branches/bos/bknr/src/utils/package.lisp 2007-10-02 10:53:43 UTC (rev 2176) +++ branches/bos/bknr/src/utils/package.lisp 2007-10-02 10:54:15 UTC (rev 2177) @@ -147,6 +147,7 @@ ;; mp compatibility #:mp-make-lock #:mp-with-lock-held + #:mp-with-recursive-lock-held ;; class utils #:class-subclasses))

1 0

[bknr-cvs] r2176 - branches/bos/bknr/src/data
by bknr＠bknr.net 02 Oct '07

02 Oct '07

Author: hhubner Date: 2007-10-02 06:53:43 -0400 (Tue, 02 Oct 2007) New Revision: 2176 Modified: branches/bos/bknr/src/data/object.lisp Log: Factor out partition function. Should be moved to utils eventually. Modified: branches/bos/bknr/src/data/object.lisp =================================================================== --- branches/bos/bknr/src/data/object.lisp 2007-09-28 17:16:21 UTC (rev 2175) +++ branches/bos/bknr/src/data/object.lisp 2007-10-02 10:53:43 UTC (rev 2176) @@ -613,16 +613,23 @@ (defmethod cascade-delete-p (object referencing-object) nil) +(defun partition-list (list predicate) + "Return two list values, the first containing all elements from LIST +that satisfy PREDICATE, the second those that don't" + (let (do dont) + (dolist (element list) + (if (funcall predicate element) + (push element do) + (push element dont))) + (values do dont))) + (defun cascading-delete-object (object) "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible to cascading deletes." - (let (cascading-delete-refs - remaining-refs) - (dolist (referencing-object (find-refs object)) - (if (cascade-delete-p object referencing-object) - (push referencing-object cascading-delete-refs) - (push referencing-object remaining-refs))) + (multiple-value-bind (cascading-delete-refs + remaining-refs) + (partition-list (find-refs object) #'cascade-delete-p) (when remaining-refs (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!" object))

1 0