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

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3450 Author: hans URL: http://bknr.net/trac/changeset/3450 Automatic recursive determination of last-change timestamp. Also store-object-touch. U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/package.lisp U trunk/bknr/datastore/src/data/txn.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-15 13:14:17 UTC (rev 3449) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-15 14:13:49 UTC (rev 3450) @@ -90,7 +90,7 @@ (error "Attempt to set persistent slot ~A of ~A outside of a transaction" slot-name object)) (unless (eq 'last-change slot-name) - (setf (slot-value object 'last-change) (transaction-timestamp *current-transaction*))))) + (setf (slot-value object 'last-change) (current-transaction-timestamp))))) (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) @@ -151,6 +151,40 @@ (error "class-instances called for nonexistent class ~A" class)) (store-objects-with-class class)) +(deftransaction store-object-touch (object) + "Update the LAST-CHANGE slot to reflect the current transaction timestamp." + (setf (slot-value object 'last-change) (current-transaction-timestamp))) + +(defgeneric store-object-last-change (object depth) + (:documentation "Return the last change time of the OBJECT. DEPTH + determines how deep the object graph will be traversed.") + + (:method (object depth) + 0) + + (:method ((object store-object) (depth (eql 0))) + (slot-value object 'last-change)) + + (:method ((object store-object) depth) + (let ((last-change (slot-value object 'last-change))) + (dolist (slotd (class-slots (class-of object))) + (let* ((slot-name (slot-definition-name slotd)) + (child (and (slot-boundp object slot-name) + (slot-value object slot-name)))) + (setf last-change + (cond + ((null child) + last-change) + ((typep child 'store-object) + (max last-change (store-object-last-change child (1- depth)))) + ((listp child) + (reduce #'max child + :key (alexandria:rcurry 'store-object-last-change (1- depth)) + :initial-value last-change)) + (t + last-change))))) + last-change))) + #+allegro (aclmop::finalize-inheritance (find-class 'store-object)) Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-07-15 13:14:17 UTC (rev 3449) +++ trunk/bknr/datastore/src/data/package.lisp 2008-07-15 14:13:49 UTC (rev 3450) @@ -28,6 +28,7 @@ #:transaction-function-symbol #:transaction-args #:transaction-timestamp + #:current-transaction-timestamp #:in-transaction-p #:deftransaction @@ -42,6 +43,8 @@ #:store-object #:store-object-store #:store-object-id + #:store-object-last-change + #:store-object-touch #:delete-object #:delete-objects Modified: trunk/bknr/datastore/src/data/txn.lisp =================================================================== --- trunk/bknr/datastore/src/data/txn.lisp 2008-07-15 13:14:17 UTC (rev 3449) +++ trunk/bknr/datastore/src/data/txn.lisp 2008-07-15 14:13:49 UTC (rev 3450) @@ -236,6 +236,9 @@ (or *current-transaction* (eq :restore (store-state *store*)))) +(defun current-transaction-timestamp () + (transaction-timestamp *current-transaction*)) + (defun store-open-p () (not (eq :closed (store-state *store*))))

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3449 Author: hans URL: http://bknr.net/trac/changeset/3449 Add automatically maintained LAST-CHANGE slot to STORE-OBJECT class. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-15 12:42:26 UTC (rev 3448) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-15 13:14:17 UTC (rev 3449) @@ -84,10 +84,13 @@ (slot-value slot 'relaxed-object-reference)) (defmethod (setf slot-value-using-class) :before (newval (class persistent-class) object slotd) - (when (and (persistent-slot-p slotd) - (not (in-transaction-p))) - (error "Attempt to set persistent slot ~A of ~A outside of a transaction" - (slot-definition-name slotd) object))) + (let ((slot-name (slot-definition-name slotd))) + (when (and (persistent-slot-p slotd) + (not (in-transaction-p))) + (error "Attempt to set persistent slot ~A of ~A outside of a transaction" + slot-name object)) + (unless (eq 'last-change slot-name) + (setf (slot-value object 'last-change) (transaction-timestamp *current-transaction*))))) (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) @@ -132,7 +135,9 @@ :index-type unique-index :index-initargs (:test #'eql) :index-reader store-object-with-id :index-values all-store-objects - :index-mapvalues map-store-objects)) + :index-mapvalues map-store-objects) + (last-change :initform (get-universal-time) + :initarg :last-change)) (:metaclass persistent-class) (:class-indices (all-class :index-type class-skip-index :index-subclasses t

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/handler-statistics-handler.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3448 Author: hans URL: http://bknr.net/trac/changeset/3448 Add function to reset statistics U trunk/bknr/web/src/web/handler-statistics-handler.lisp Modified: trunk/bknr/web/src/web/handler-statistics-handler.lisp =================================================================== --- trunk/bknr/web/src/web/handler-statistics-handler.lisp 2008-07-15 12:16:38 UTC (rev 3447) +++ trunk/bknr/web/src/web/handler-statistics-handler.lisp 2008-07-15 12:42:26 UTC (rev 3448) @@ -31,4 +31,9 @@ (fastest-entry (aref fastest-array (1- (array-dimension fastest-array 0))))) (when fastest-entry (html - (:princ (format-elapsed (car fastest-entry)))))))))))))))) \ No newline at end of file + (:princ (format-elapsed (car fastest-entry)))))))))))))))) + +(defun reset-handler-statistics () + (dolist (handler (website-handlers *website*)) + (setf (page-handler-statistics handler) (make-handler-statistics)))) +

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3447 Author: hans URL: http://bknr.net/trac/changeset/3447 Add statistics handler to measure handler execution speed. U trunk/bknr/web/src/bknr.web.asd A trunk/bknr/web/src/web/handler-statistics-handler.lisp U trunk/bknr/web/src/web/handlers.lisp U trunk/projects/bos/web/webserver.lisp U trunk/projects/lisp-ecoop/src/webserver.lisp U trunk/thirdparty/closure-common/closure-common.asd Modified: trunk/bknr/web/src/bknr.web.asd =================================================================== --- trunk/bknr/web/src/bknr.web.asd 2008-07-15 12:08:19 UTC (rev 3446) +++ trunk/bknr/web/src/bknr.web.asd 2008-07-15 12:16:38 UTC (rev 3447) @@ -79,6 +79,9 @@ "sessions" "site")) + (:file "handler-statistics-handler" + :depends-on ("handlers")) + (:file "template-handler" :depends-on ("handlers")) Added: trunk/bknr/web/src/web/handler-statistics-handler.lisp =================================================================== --- trunk/bknr/web/src/web/handler-statistics-handler.lisp (rev 0) +++ trunk/bknr/web/src/web/handler-statistics-handler.lisp 2008-07-15 12:16:38 UTC (rev 3447) @@ -0,0 +1,34 @@ +(in-package :bknr.web) + +(defclass handler-statistics-handler (page-handler) + ()) + +(defun format-elapsed (internal-time-units) + (format nil "~8,1F" (* 1000 (/ internal-time-units internal-time-units-per-second)))) + +(defmethod handle ((handler handler-statistics-handler)) + (with-bknr-page (:title "BKNR handler statistics") + (:div "All times reported in milliseconds") + (:table + (:thead + (:tr (:th "Prefix") (:th "Type") (:th "Pages") (:th "Average") (:th "Max") (:th "Min"))) + (:tbody + (dolist (handler (website-handlers *website*)) + (let ((statistics (page-handler-statistics handler))) + (when (and (hs-count statistics) + (plusp (hs-count statistics))) + (html + (:tr (:td (:princ (page-handler-prefix handler))) + (:td (:princ (class-name (class-of handler)))) + ((:td :align "right") (:princ (hs-count statistics))) + ((:td :align "right") (:princ (format-elapsed (hs-average statistics)))) + ((:td :align "right") (let* ((slowest-array (hs-slowest statistics)) + (slowest-entry (aref slowest-array (1- (array-dimension slowest-array 0))))) + (when slowest-entry + (html + (:princ (format-elapsed (car slowest-entry))))))) + ((:td :align "right") (let* ((fastest-array (hs-fastest statistics)) + (fastest-entry (aref fastest-array (1- (array-dimension fastest-array 0))))) + (when fastest-entry + (html + (:princ (format-elapsed (car fastest-entry)))))))))))))))) \ No newline at end of file Modified: trunk/bknr/web/src/web/handlers.lisp =================================================================== --- trunk/bknr/web/src/web/handlers.lisp 2008-07-15 12:08:19 UTC (rev 3446) +++ trunk/bknr/web/src/web/handlers.lisp 2008-07-15 12:16:38 UTC (rev 3447) @@ -210,7 +210,9 @@ :reader page-handler-content-type :initform "text/html") (site :initarg :site - :reader page-handler-site)) + :reader page-handler-site) + (statistics :initform (make-handler-statistics) + :accessor page-handler-statistics)) (:documentation "Simple page handler publishing a serve request under a simple URL")) (defmethod initialize-instance :after ((handler page-handler) &key name prefix &allow-other-keys) @@ -224,6 +226,50 @@ (print-unreadable-object (handler stream :type t) (format stream "~A" (page-handler-prefix handler)))) +;; Each handler has a statistics record that keeps track of the +;; slowest and fastest URLs on this handler and the average time that +;; processing on this handler takes. + +(defconstant +statistics-keep-atypical-count+ 10) + +(defstruct (handler-statistics (:conc-name hs-)) + (slowest (make-array +statistics-keep-atypical-count+ :initial-element nil)) + (fastest (make-array +statistics-keep-atypical-count+ :initial-element nil)) + (count 0) + average) + +(defun slowest-time (statistics) + (or (car (aref (hs-slowest statistics) 0)) + 0)) + +(defun fastest-time (statistics) + (or (car (aref (hs-fastest statistics) 0)) + most-positive-fixnum)) + +(defun note-run-time-for-statistics (handler run-time) + (let ((statistics (page-handler-statistics handler))) + (when (< run-time (fastest-time statistics)) + (setf (aref (hs-fastest statistics) 0) (cons run-time (tbnl:script-name*)) + (hs-fastest statistics) (sort (hs-fastest statistics) #'> + :key (lambda (entry) + (or (car entry) + most-positive-fixnum))))) + (when (> run-time (slowest-time statistics)) + (setf (aref (hs-slowest statistics) 0) (cons run-time (tbnl:script-name*)) + (hs-slowest statistics) (sort (hs-slowest statistics) #'< + :key (lambda (entry) + (or (car entry) + 0))))) + (cond + ((plusp (hs-count statistics)) + (setf (hs-average statistics) (/ (+ (* (hs-count statistics) (hs-average statistics)) + run-time) + (1+ (hs-count statistics)))) + (incf (hs-count statistics))) + (t + (setf (hs-average statistics) run-time + (hs-count statistics) 1))))) + (defgeneric handle (page-handler) (:documentation "Handle an incoming HTTP request, returning either a string or an (array (unsigned-byte 8) (*)) with the response @@ -279,8 +325,13 @@ (with-http-body () (website-show-error-page *website* e)) (do-error-log-request e))))))) - (handle handler)))) + (let ((start (get-internal-real-time))) + (prog1 + (handle handler) + (let ((duration (- (get-internal-real-time) start))) + (note-run-time-for-statistics handler duration))))))) + (defmethod handle ((page-handler page-handler)) (funcall (page-handler-function page-handler))) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-15 12:08:19 UTC (rev 3446) +++ trunk/projects/bos/web/webserver.lisp 2008-07-15 12:16:38 UTC (rev 3447) @@ -238,6 +238,7 @@ ("/cancel-contract" cancel-contract-handler) ("/statistics" statistics-handler) ("/rss" rss-handler) + ("/handler-statistics" bknr.web::handler-statistics-handler) ("/favicon.ico" file-handler :destination ,(merge-pathnames #p"static/favicon.ico" website-directory) Modified: trunk/projects/lisp-ecoop/src/webserver.lisp =================================================================== --- trunk/projects/lisp-ecoop/src/webserver.lisp 2008-07-15 12:08:19 UTC (rev 3446) +++ trunk/projects/lisp-ecoop/src/webserver.lisp 2008-07-15 12:16:38 UTC (rev 3447) @@ -25,6 +25,7 @@ :handler-definitions `(user images stats + ("/handler-statistics" bknr.web::handler-statistics-handler) mailinglist mailinglist-registration participants schedule Modified: trunk/thirdparty/closure-common/closure-common.asd =================================================================== --- trunk/thirdparty/closure-common/closure-common.asd 2008-07-15 12:08:19 UTC (rev 3446) +++ trunk/thirdparty/closure-common/closure-common.asd 2008-07-15 12:16:38 UTC (rev 3447) @@ -26,7 +26,8 @@ #+rune-is-character (error "conflicting unicode configuration. Please recompile.") (pushnew :rune-is-integer *features*)) - ((ignore-errors (code-char 70000)) + (#+cmu (ignore-errors (code-char 70000)) + #-cmu (code-char 70000) (when (test #xD800) (format t " WARNING: Lisp implementation doesn't use UTF-16, ~ but accepts surrogate code points.~%"))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/tsung2.xml
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3446 Author: ksprotte URL: http://bknr.net/trac/changeset/3446 new tsung config tsung2.xml A trunk/projects/bos/test/tsung2.xml Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/indices/indexed-class.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3445 Author: hans URL: http://bknr.net/trac/changeset/3445 Only use slot-boundp/slot-value on objects (not NIL) U trunk/bknr/datastore/src/indices/indexed-class.lisp Modified: trunk/bknr/datastore/src/indices/indexed-class.lisp =================================================================== --- trunk/bknr/datastore/src/indices/indexed-class.lisp 2008-07-15 11:38:41 UTC (rev 3444) +++ trunk/bknr/datastore/src/indices/indexed-class.lisp 2008-07-15 11:47:24 UTC (rev 3445) @@ -457,6 +457,7 @@ (destroy-object-with-class (class-of object) object)) (defmethod object-destroyed-p ((object t)) - (and (slot-boundp object 'destroyed-p) + (and object + (slot-boundp object 'destroyed-p) (slot-value object 'destroyed-p)))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/tsung.xml
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3444 Author: ksprotte URL: http://bknr.net/trac/changeset/3444 tsung config changed to host horst.headcraft.de U trunk/projects/bos/test/tsung.xml Modified: trunk/projects/bos/test/tsung.xml =================================================================== --- trunk/projects/bos/test/tsung.xml 2008-07-15 11:24:47 UTC (rev 3443) +++ trunk/projects/bos/test/tsung.xml 2008-07-15 11:38:41 UTC (rev 3444) @@ -9,7 +9,7 @@  <servers> - <server host="jasmin.headcraft.de" port="80" type="tcp"></server> + <server host="horst.headcraft.de" port="80" type="tcp"></server> </servers> <!-- to start os monitoring (cpu, network, memory). Use an erlang

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/indices/indexed-class.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3443 Author: hans URL: http://bknr.net/trac/changeset/3443 Don't use signals in order to find out if an object is destroyed. U trunk/bknr/datastore/src/indices/indexed-class.lisp Modified: trunk/bknr/datastore/src/indices/indexed-class.lisp =================================================================== --- trunk/bknr/datastore/src/indices/indexed-class.lisp 2008-07-15 10:46:03 UTC (rev 3442) +++ trunk/bknr/datastore/src/indices/indexed-class.lisp 2008-07-15 11:24:47 UTC (rev 3443) @@ -457,8 +457,6 @@ (destroy-object-with-class (class-of object) object)) (defmethod object-destroyed-p ((object t)) - (handler-case - (slot-value object 'destroyed-p) - (unbound-slot () nil) - (simple-error () nil))) + (and (slot-boundp object 'destroyed-p) + (slot-value object 'destroyed-p)))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-image-handler.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3442 Author: ksprotte URL: http://bknr.net/trac/changeset/3442 contract-image-handler: small fix. gives a more explanatory error message when the contract does not exist U trunk/projects/bos/web/contract-image-handler.lisp Modified: trunk/projects/bos/web/contract-image-handler.lisp =================================================================== --- trunk/projects/bos/web/contract-image-handler.lisp 2008-07-15 10:14:00 UTC (rev 3441) +++ trunk/projects/bos/web/contract-image-handler.lisp 2008-07-15 10:46:03 UTC (rev 3442) @@ -27,4 +27,8 @@ (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) (setf (cl-gd:raw-pixel) (aref work-array x y))))) - (emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t)))) \ No newline at end of file + (emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t)))) + +(defmethod handle-object ((handler contract-image-handler) (contract null)) + (error "no contract found")) +

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3441 Author: ksprotte URL: http://bknr.net/trac/changeset/3441 contract-node-invalidate-timestamp: only need to update timestamp if the corresponding blob exists U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-15 10:07:07 UTC (rev 3440) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-15 10:14:00 UTC (rev 3441) @@ -11,10 +11,8 @@ (defun contract-node-invalidate-timestamp (node) (let ((image (contract-node-find-corresponding-store-image node))) - (setf (timestamp node) - (if (and image (probe-file (blob-pathname image))) - (1+ (blob-timestamp image)) - (get-universal-time))))) + (when (and image (probe-file (blob-pathname image))) + (setf (timestamp node) (1+ (blob-timestamp image)))))) (defun contract-node-timestamp-updater (contract) (lambda (node) (setf (timestamp node)

1 0