[bknr-cvs] r2180 - in trunk/bknr/src: . data indices sysclasses utils web xml-impex

bknr at bknr.net bknr at bknr.net
Thu Oct 4 07:41:40 UTC 2007


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)
     , at body))
+
+(defmacro mp-with-recursive-lock-held ((lock) &rest body)
+  #+allegro
+  `(mp:with-process-lock (,lock)
+    , at body)
+  #+sbcl
+  `(sb-thread:with-recursive-lock (,lock)
+     , at body)
+  #+cmu
+  `(mp:with-lock-held (,lock)
+    , at 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




More information about the Bknr-cvs mailing list