bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] ksprotte changed trunk/projects/bos/test/fixtures.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3453 Author: ksprotte URL: http://bknr.net/trac/changeset/3453 made bos test fixture INITIAL-BOS-STORE more robust for ccl U trunk/projects/bos/test/fixtures.lisp Modified: trunk/projects/bos/test/fixtures.lisp =================================================================== --- trunk/projects/bos/test/fixtures.lisp 2008-07-15 15:44:31 UTC (rev 3452) +++ trunk/projects/bos/test/fixtures.lisp 2008-07-16 08:59:09 UTC (rev 3453) @@ -56,8 +56,9 @@ :website-url bos.m2::*website-url*) (make-user "anonymous") ; needed for web tests (&body)) - (close-store) - (cl-fad:delete-directory-and-files store-path)))) + (close-store) + ;; (cl-fad:delete-directory-and-files store-path) ; fails on ccl + (asdf:run-shell-command "rm -r '~A'" store-path)))) (defmacro store-test (name &body body) `(progn

1 0

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

15 Jul '08

Revision: 3452 Author: ksprotte URL: http://bknr.net/trac/changeset/3452 poi-kml-all-handler now uses last-modifiepoi-kml-all-handler now uses last-modifiedd U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-15 14:37:26 UTC (rev 3451) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-15 15:44:31 UTC (rev 3452) @@ -576,22 +576,26 @@ ()) (defmethod handle ((handler poi-kml-all-handler)) - (with-query-params ((lang "en")) - (with-xml-response () - ;; (sax:processing-instruction cxml::*sink* "xml-stylesheet" "href=\"/static/tri.xsl\" type=\"text/xsl\"") - (with-namespace (nil "http://earth.google.com/kml/2.1") - (with-element "kml" - (with-element "Document" - (with-element "Style" - (attribute "id" "poiPlacemarkIcon") - (with-element "IconStyle" - ;; (with-element "color" (text "ffffffff")) - (with-element "scale" (text "0.8")) - (with-element "Icon" - (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) '(:min 600 :max -1)) - (mapc #'(lambda (poi) (write-poi-kml poi lang)) - (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published poi))) - (class-instances 'poi))))))))) + (let* ((relevant-pois (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published poi))) + (class-instances 'poi))) + (pois-last-change (reduce #'max relevant-pois :key (lambda (poi) (store-object-last-change poi 1))))) + (hunchentoot:handle-if-modified-since pois-last-change) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date pois-last-change)) + (with-query-params ((lang "en")) + (with-xml-response () + ;; (sax:processing-instruction cxml::*sink* "xml-stylesheet" "href=\"/static/tri.xsl\" type=\"text/xsl\"") + (with-namespace (nil "http://earth.google.com/kml/2.1") + (with-element "kml" + (with-element "Document" + (with-element "Style" + (attribute "id" "poiPlacemarkIcon") + (with-element "IconStyle" + ;; (with-element "color" (text "ffffffff")) + (with-element "scale" (text "0.8")) + (with-element "Icon" + (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) + (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) '(:min 600 :max -1)) + (mapc #'(lambda (poi) (write-poi-kml poi lang)) relevant-pois))))))))

1 0

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

15 Jul '08

Revision: 3451 Author: ksprotte URL: http://bknr.net/trac/changeset/3451 dont update store-object's last-change slot during restore 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 14:13:49 UTC (rev 3450) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-15 14:37:26 UTC (rev 3451) @@ -89,7 +89,8 @@ (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) + (unless (or (eq :restore (store-state *store*)) + (eq 'last-change slot-name)) (setf (slot-value object 'last-change) (current-transaction-timestamp))))) (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd)

1 0

[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

← Newer
1
...
24
25
26
27
28
29
30
...
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008