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

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3490 Author: ksprotte URL: http://bknr.net/trac/changeset/3490 dont start-contract-tree-image-update-daemon make-contract-tree-from-m2 U trunk/projects/bos/build.lisp U trunk/projects/bos/test/fixtures.lisp U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/build.lisp =================================================================== --- trunk/projects/bos/build.lisp 2008-07-17 13:59:38 UTC (rev 3489) +++ trunk/projects/bos/build.lisp 2008-07-17 14:11:47 UTC (rev 3490) @@ -69,7 +69,8 @@ (swank:create-server :port ~D :dont-close t))" swank-port))) ;; start the bos server (apply #'bos.m2::reinit (read-configuration "m2.rc")) - (apply #'bos.web::init (read-configuration "web.rc")) + (apply #'bos.web::init (read-configuration "web.rc")) + (bos.web::start-contract-tree-image-update-daemon) (bknr.cron::start-cron)) (defun start-cert-daemon () Modified: trunk/projects/bos/test/fixtures.lisp =================================================================== --- trunk/projects/bos/test/fixtures.lisp 2008-07-17 13:59:38 UTC (rev 3489) +++ trunk/projects/bos/test/fixtures.lisp 2008-07-17 14:11:47 UTC (rev 3490) @@ -5,9 +5,8 @@ (when snapshot (format t "~&;; ++ taking snapshot~%") (snapshot)) - (let ((bos.web::*start-contract-tree-image-update-daemon* nil)) - (bos.m2::reinit :directory (bknr.datastore::store-directory *store*) - :website-url bos.m2::*website-url*)) + (bos.m2::reinit :directory (bknr.datastore::store-directory *store*) + :website-url bos.m2::*website-url*) (format t "~&;; ++ reopen-store done~%")) (defmacro reopen-store ((&key snapshot) &rest store-object-vars) @@ -51,7 +50,7 @@ (let ((store-path (parse-namestring (format nil "/tmp/test-store-~D.tmp/" (get-universal-time))))) (unwind-protect - (let ((bos.web::*start-contract-tree-image-update-daemon* nil)) + (progn (bos.m2::reinit :delete t :directory store-path :website-url bos.m2::*website-url*) Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-17 13:59:38 UTC (rev 3489) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-17 14:11:47 UTC (rev 3490) @@ -306,7 +306,6 @@ ;; contract-tree image update daemon (defvar *contract-tree-image-update-daemon* nil) (defvar *contract-tree-image-update-daemon-halt*) -(defvar *start-contract-tree-image-update-daemon* t) (defun contract-tree-image-update-daemon-loop () (loop (when *contract-tree-image-update-daemon-halt* (return)) @@ -346,9 +345,7 @@ (dolist (contract (class-instances 'contract)) (when (contract-published-p contract) (insert-contract *contract-tree* contract))) - (format t "~&rendering contract-tree images if needed...") (force-output) - (when *start-contract-tree-image-update-daemon* - (start-contract-tree-image-update-daemon)) + (format t "~&rendering contract-tree images if needed...") (force-output) (format t "done.~%") (force-output) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* (list 0 0 +width+ +width+)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3489 Author: ksprotte URL: http://bknr.net/trac/changeset/3489 a temporary fix to invoke-store-transient-init-functions before the transaction-log is forwarded U trunk/projects/bos/m2/allocation-cache.lisp U trunk/projects/bos/m2/m2-store.lisp Modified: trunk/projects/bos/m2/allocation-cache.lisp =================================================================== --- trunk/projects/bos/m2/allocation-cache.lisp 2008-07-17 13:06:23 UTC (rev 3488) +++ trunk/projects/bos/m2/allocation-cache.lisp 2008-07-17 13:59:38 UTC (rev 3489) @@ -260,7 +260,8 @@ (defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) &key until) (declare (ignore until)) - (rebuild-cache)) + (rebuild-cache) + (bos.m2::invoke-store-transient-init-functions)) (defmethod bknr.datastore::snapshot-subsystem (store (subsystem allocation-cache-subsystem)) ) \ No newline at end of file Modified: trunk/projects/bos/m2/m2-store.lisp =================================================================== --- trunk/projects/bos/m2/m2-store.lisp 2008-07-17 13:06:23 UTC (rev 3488) +++ trunk/projects/bos/m2/m2-store.lisp 2008-07-17 13:59:38 UTC (rev 3489) @@ -64,8 +64,6 @@ *store-transient-init-constraints* new-store-transient-init-constraints)))) -(defmethod bknr.datastore::restore-store :after ((store m2-store) &key until) - (declare (ignore store until)) +(defun invoke-store-transient-init-functions () (dolist (function-name *store-transient-init-functions*) - (funcall function-name))) - + (funcall function-name))) \ No newline at end of file

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3488 Author: ksprotte URL: http://bknr.net/trac/changeset/3488 country-stats-handler now uses queries from contract-stats U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 12:57:00 UTC (rev 3487) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 13:06:23 UTC (rev 3488) @@ -591,7 +591,7 @@ (defstruct contract-stats (sold-m2s 0) (paying-sponsors 0) - (country-sponsors (make-hash-table :test #'equal)) + (country-sponsors (make-hash-table)) (last-contracts (make-list +last-contracts-cache-size+))) (defun initialize-contract-stats () @@ -603,8 +603,7 @@ (let* ((area (contract-area contract)) (sponsor (contract-sponsor contract)) (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor))) - (%country (sponsor-country sponsor)) - (country (and %country (string-upcase %country)))) + (country (sponsor-country sponsor))) (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts) *contract-stats* ;; sold-m2s @@ -631,6 +630,7 @@ (contract-stats-paying-sponsors *contract-stats*)) (defun contract-stats-for-country (country) + (assert (keywordp country)) (let ((stat (gethash country (contract-stats-country-sponsors *contract-stats*)))) (if stat (values (country-stat-paying-sponsors stat) @@ -643,16 +643,12 @@ (object-destroyed-p contract))) (contract-stats-last-contracts *contract-stats*))) -(defun invoke-with-countries (function as-keyword) - (alexandria:maphash-keys - (if as-keyword - (lambda (country) (funcall function (make-keyword-from-string country))) - function) - (contract-stats-country-sponsors *contract-stats*))) +(defun invoke-with-countries (function) + (alexandria:maphash-keys function (contract-stats-country-sponsors *contract-stats*))) -(defmacro do-countries ((country &key as-keyword) &body body) +(defmacro do-sponsor-countries ((country) &body body) (check-type country symbol) - `(invoke-with-countries (lambda (,country) ,@body) ,as-keyword)) + `(invoke-with-countries (lambda (,country) ,@body))) (register-store-transient-init-function 'initialize-contract-stats) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-17 12:57:00 UTC (rev 3487) +++ trunk/projects/bos/m2/packages.lisp 2008-07-17 13:06:23 UTC (rev 3488) @@ -170,7 +170,7 @@ #:number-of-paying-sponsors #:contract-stats-for-country #:last-paid-contracts - #:do-countries + #:do-sponsor-countries #:make-m2-javascript #:recolorize-contracts Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-17 12:57:00 UTC (rev 3487) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-17 13:06:23 UTC (rev 3488) @@ -154,18 +154,14 @@ (with-element "IconStyle" (with-element "Icon" ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) - (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (dolist (country-contracts (sort (group-on (remove-if-not #'contract-paidp contracts) - :test #'equal - :key (lambda (contract) - (string-upcase (sponsor-country (contract-sponsor contract))))) - #'> :key (lambda (entry) (length (cdr entry))))) - (let ((coords (cdr (assoc (make-keyword-from-string (car country-contracts)) *country-coords*)))) + (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) + (do-sponsor-countries (country) + (let ((coords (cdr (assoc country *country-coords*)))) (when coords (destructuring-bind (lon lat) coords - (let* ((contracts (cdr country-contracts)) - (number-contracts (length contracts))) + (multiple-value-bind (number-of-paying-sponsors number-of-sold-m2s) + (contract-stats-for-country country) (with-element "Placemark" ;; (with-element "name" (text (format nil "~a ~a" (car country-contracts) (length (cdr country-contracts))))) (with-element "styleUrl" (text "#countryStatsStyle")) @@ -174,13 +170,13 @@ <tr><td>~A:</td><td>~D m²</td></tr></tbody></table>" (dictionary-entry "BOS says thank you to all sponsors!" lang) (dictionary-entry - (second (assoc (make-keyword-from-string (car country-contracts)) *country-english-names*)) lang) - number-contracts - (if (= 1 number-contracts) + (second (assoc country *country-english-names*)) lang) + number-of-paying-sponsors + (if (= 1 number-of-paying-sponsors) (dictionary-entry "sponsor" lang) (dictionary-entry "sponsors" lang)) (dictionary-entry "total contribution" lang) - (reduce #'+ contracts :key #'contract-area)))) + number-of-sold-m2s))) (with-element "Point" (with-element "coordinates" (text (format nil "~,20F,~,20F,0" lat lon)))))))))))))))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3487 Author: hans URL: http://bknr.net/trac/changeset/3487 Split up setting up the socket to listen for connections and accepting connections into two steps. The reason for this change is that listening is better done in the thread/process that invokes START-SERVER, as errors will then be reported directly (EADDRINUSE comes to mind) and that the caller of START-SERVER can be sure that the server will be ready enough to accept connections once START-SERVER returns. "listeners" are now called "acceptors" to reflect the new world. For Lispworks, the TCP server process will be stopped after it has been and then unstopped to actually begin serving requests. This is not strictly needed, but this way the behaviour of Lispworks and non-Lispworks is similar. U trunk/thirdparty/hunchentoot/connection-manager.lisp U trunk/thirdparty/hunchentoot/doc/index.xml U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/server.lisp Modified: trunk/thirdparty/hunchentoot/connection-manager.lisp =================================================================== --- trunk/thirdparty/hunchentoot/connection-manager.lisp 2008-07-17 12:50:50 UTC (rev 3486) +++ trunk/thirdparty/hunchentoot/connection-manager.lisp 2008-07-17 12:57:00 UTC (rev 3487) @@ -40,11 +40,11 @@ (:documentation "Base class for all connection managers classes. Its purpose is to carry the back pointer to the server instance.")) -(defgeneric execute-listener (connection-manager) +(defgeneric execute-acceptor (connection-manager) (:documentation "This function is called once Hunchentoot has performed all initial processing to start listening for incoming connections. It does so by -calling the LISTEN-FOR-CONNECTIONS functions of the server, taken from +calling the ACCEPT-CONNECTIONS functions of the server, taken from the SERVER slot of the connection manager instance. In a multi-threaded environment, the connection manager starts a new @@ -70,7 +70,6 @@ (:documentation "Terminate all threads that are currently associated with the connection manager, if any.") (:method (manager) - (declare (ignore manager)) #+:lispworks (when-let (listener (server-listener (server manager))) ;; kill the main listener process, see LW documentation for @@ -82,28 +81,38 @@ (:documentation "Connection manager that runs synchronously in the thread that invoked the START-SERVER function.")) -(defmethod execute-listener ((manager single-threaded-connection-manager)) - (listen-for-connections (server manager))) +(defmethod execute-acceptor ((manager single-threaded-connection-manager)) + (accept-connections (server manager))) (defmethod handle-incoming-connection ((manager single-threaded-connection-manager) socket) (process-connection (server manager) socket)) (defclass one-thread-per-connection-manager (connection-manager) - () + ((acceptor-process :accessor acceptor-process + :documentation "Process that accepts incoming + connections and dispatches them to new processes + for request execution.")) (:documentation "Connection manager that starts one thread for listening to incoming requests and one thread for each incoming connection.")) -(defmethod execute-listener ((manager one-thread-per-connection-manager)) +(defmethod execute-acceptor ((manager one-thread-per-connection-manager)) #+:lispworks - (listen-for-connections (server manager)) + (accept-connections (server manager)) #-:lispworks - (bt:make-thread (lambda () - (listen-for-connections (server manager))) - :name (format nil "Hunchentoot listener \(~A:~A)" - (or (server-address (server manager)) "*") - (server-port (server manager))))) + (setf (acceptor-process manager) + (bt:make-thread (lambda () + (accept-connections (server manager))) + :name (format nil "Hunchentoot acceptor \(~A:~A)" + (or (server-address (server manager)) "*") + (server-port (server manager)))))) +#-:lispworks +(defmethod shutdown ((manager one-thread-per-connection-manager)) + (loop + while (bt:thread-alive-p (acceptor-process manager)) + do (sleep 1))) + #+:lispworks (defmethod handle-incoming-connection ((manager one-thread-per-connection-manager) handle) (incf *worker-counter*) Modified: trunk/thirdparty/hunchentoot/doc/index.xml =================================================================== --- trunk/thirdparty/hunchentoot/doc/index.xml 2008-07-17 12:50:50 UTC (rev 3486) +++ trunk/thirdparty/hunchentoot/doc/index.xml 2008-07-17 12:57:00 UTC (rev 3487) @@ -531,6 +531,7 @@ <clix:special-variable name="*cleanup-interval*"> <clix:description> + (Lispworks only) Should be <code>NIL</code> or a positive integer. The system calls <clix:ref>*CLEANUP-FUNCTION*</clix:ref> whenever <clix:ref>*CLEANUP-INTERVAL*</clix:ref> new worker @@ -541,13 +542,13 @@ <clix:special-variable name="*cleanup-function*"> <clix:description> + (Lispworks only) The function (with no arguments) which is called if <clix:ref>*CLEANUP-INTERVAL*</clix:ref> is not <code>NIL</code>. The initial value is a function which calls <code>(<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-166.htm">HCL</a>:<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-212.htm"> - <code>MARK-AND-SWEEP</code> </a> 2)</code> on LispWorks and - does nothing on other Lisps. + <code>MARK-AND-SWEEP</code> </a> 2)</code>. <p> On LispWorks this is necessary because each <em>worker</em> (which is created to handle an incoming http request and Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2008-07-17 12:50:50 UTC (rev 3486) +++ trunk/thirdparty/hunchentoot/packages.lisp 2008-07-17 12:57:00 UTC (rev 3487) @@ -40,7 +40,9 @@ (:import-from :lw "WITH-UNIQUE-NAMES" "WHEN-LET") (:export "*APPROVED-RETURN-CODES*" "*CATCH-ERRORS-P*" + #+:lispworks "*CLEANUP-FUNCTION*" + #+:lispworks "*CLEANUP-INTERVAL*" "*CONTENT-TYPES-FOR-URL-REWRITE*" "*DEFAULT-CONNECTION-TIMEOUT*" Modified: trunk/thirdparty/hunchentoot/server.lisp =================================================================== --- trunk/thirdparty/hunchentoot/server.lisp 2008-07-17 12:50:50 UTC (rev 3486) +++ trunk/thirdparty/hunchentoot/server.lisp 2008-07-17 12:57:00 UTC (rev 3487) @@ -81,9 +81,13 @@ responsible for listening to new connections and scheduling them for execution.") #+:lispworks - (listener :accessor server-listener - :documentation "The Lisp process which listens for -incoming requests.") + (acceptor :accessor server-acceptor + :documentation "The Lisp process which accepts incoming + requests.") + #-:lispworks + (listen-socket :accessor server-listen-socket + :documentation "The listen socket for incoming + connections.") (server-shutdown-p :initform nil :accessor server-shutdown-p :documentation "Flag that makes the server @@ -191,13 +195,16 @@ (:documentation "Start the SERVER so that it begins accepting connections.") (:method ((server server)) - (execute-listener (server-connection-manager server)))) + (start-listening server) + (execute-acceptor (server-connection-manager server)))) (defgeneric stop (server) (:documentation "Stop the SERVER so that it does no longer accept requests.") (:method ((server server)) (setf (server-shutdown-p server) t) - (shutdown (server-connection-manager server)))) + (shutdown (server-connection-manager server)) + #-:lispworks + (usocket:socket-close (server-listen-socket server)))) (defun start-server (&rest args &key port address dispatch-table name @@ -339,51 +346,66 @@ "Time in seconds to wait for a new connection to arrive before performing a cleanup run.") -(defgeneric listen-for-connections (server) +(defgeneric start-listening (server) (:documentation "Sets up a listen socket for the given SERVER and -listens for incoming connections. In a loop, accepts a connection and +enables it to listen for incoming connections. This function is +called from the thread that starts the server initially and may return +errors resulting from the listening operation. (like 'address in use' +or similar).") + (:method ((server server)) + #+:lispworks + (multiple-value-bind (listener-process startup-condition) + (comm:start-up-server :service (server-port server) + :address (server-address server) + :process-name (format nil "Hunchentoot listener \(~A:~A)" + (or (server-address server) "*") (server-port server)) + ;; this function is called once on startup - we + ;; use it to check for errors + :announce (lambda (socket &optional condition) + (declare (ignore socket)) + (when condition + (error condition))) + ;; this function is called whenever a connection + ;; is made + :function (lambda (handle) + (unless (server-shutdown-p server) + (handle-incoming-connection + (server-connection-manager server) handle))) + ;; wait until the server was successfully started + ;; or an error condition is returned + :wait t) + (when startup-condition + (error startup-condition)) + (process-stop listener-process) + (setf (server-acceptor server) listener-process)) + #-:lispworks + (setf (server-listen-socket server) + (usocket:socket-listen (or (server-address server) + usocket:*wildcard-host*) + (server-port server) + :reuseaddress t + :element-type '(unsigned-byte 8))))) + +(defgeneric accept-connections (server) + (:documentation "In a loop, accepts a connection and dispatches it to the server's connection manager object for processing using HANDLE-INCOMING-CONNECTION.") (:method ((server server)) - #+:lispworks - (setf (server-listener server) - (comm:start-up-server :service (server-port server) - :address (server-address server) - :process-name (format nil "Hunchentoot listener \(~A:~A)" - (or (server-address server) "*") (server-port server)) - ;; this function is called once on startup - we - ;; use it to check for errors - :announce (lambda (socket &optional condition) - (declare (ignore socket)) - (when condition - (error condition))) - ;; this function is called whenever a connection - ;; is made - :function (lambda (handle) - (unless (server-shutdown-p server) - (handle-incoming-connection - (server-connection-manager server) handle))) - ;; wait until the server was successfully started - ;; or an error condition is returned - :wait t)) - #-:lispworks - (usocket:with-socket-listener (listener - (or (server-address server) - usocket:*wildcard-host*) - (server-port server) - :reuseaddress t - :element-type '(unsigned-byte 8)) - (do ((new-connection-p (usocket:wait-for-input listener :timeout +new-connection-wait-time+) - (usocket:wait-for-input listener :timeout +new-connection-wait-time+))) - ((server-shutdown-p server)) - (when new-connection-p - (let ((client-connection (usocket:socket-accept listener))) - (when client-connection - (set-timeouts client-connection - (server-read-timeout server) - (server-write-timeout server)) - (handle-incoming-connection (server-connection-manager server) - client-connection)))))))) + #+:lispworks + (process-unstop (server-acceptor server)) + #-:lispworks + (usocket:with-server-socket (listener (server-listen-socket server)) + (do ((new-connection-p (usocket:wait-for-input listener :timeout +new-connection-wait-time+) + (usocket:wait-for-input listener :timeout +new-connection-wait-time+))) + ((server-shutdown-p server)) + (when new-connection-p + (let ((client-connection (usocket:socket-accept listener))) + (when client-connection + (set-timeouts client-connection + (server-read-timeout server) + (server-write-timeout server)) + (handle-incoming-connection (server-connection-manager server) + client-connection)))))))) (defgeneric initialize-connection-stream (server stream) (:documentation "Wraps the given STREAM with all the additional

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3486 Author: ksprotte URL: http://bknr.net/trac/changeset/3486 new macro do-countries and some bugfixes to contract-stats U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 12:22:38 UTC (rev 3485) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 12:50:50 UTC (rev 3486) @@ -603,21 +603,23 @@ (let* ((area (contract-area contract)) (sponsor (contract-sponsor contract)) (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor))) - (country (string-upcase (sponsor-country sponsor)))) + (%country (sponsor-country sponsor)) + (country (and %country (string-upcase %country)))) (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts) - *contract-stats* + *contract-stats* ;; sold-m2s (incf sold-m2s area) ;; paying-sponsors (when new-sponsor-p - (incf paying-sponsors)) + (incf paying-sponsors)) ;; country-sponsors - (let ((country-stat (gethash country country-sponsors))) - (unless country-stat - (setq country-stat (setf (gethash country country-sponsors) (make-country-stat)))) - (when new-sponsor-p - (incf (country-stat-paying-sponsors country-stat))) - (incf (country-stat-sold-m2s country-stat) area)) + (when country + (let ((country-stat (gethash country country-sponsors))) + (unless country-stat + (setq country-stat (setf (gethash country country-sponsors) (make-country-stat)))) + (when new-sponsor-p + (incf (country-stat-paying-sponsors country-stat))) + (incf (country-stat-sold-m2s country-stat) area))) ;; last-contracts (setf last-contracts (nbutlast last-contracts)) (push contract last-contracts)))) @@ -641,6 +643,17 @@ (object-destroyed-p contract))) (contract-stats-last-contracts *contract-stats*))) +(defun invoke-with-countries (function as-keyword) + (alexandria:maphash-keys + (if as-keyword + (lambda (country) (funcall function (make-keyword-from-string country))) + function) + (contract-stats-country-sponsors *contract-stats*))) + +(defmacro do-countries ((country &key as-keyword) &body body) + (check-type country symbol) + `(invoke-with-countries (lambda (,country) ,@body) ,as-keyword)) + (register-store-transient-init-function 'initialize-contract-stats) (defun string-safe (string) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-17 12:22:38 UTC (rev 3485) +++ trunk/projects/bos/m2/packages.lisp 2008-07-17 12:50:50 UTC (rev 3486) @@ -170,6 +170,7 @@ #:number-of-paying-sponsors #:contract-stats-for-country #:last-paid-contracts + #:do-countries #:make-m2-javascript #:recolorize-contracts

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/p
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3485 Author: ksprotte URL: http://bknr.net/trac/changeset/3485 make-poi-javascript now uses faster queries from contract-stats U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-17 12:19:24 UTC (rev 3484) +++ trunk/projects/bos/m2/packages.lisp 2008-07-17 12:22:38 UTC (rev 3485) @@ -167,7 +167,7 @@ #:contract-download-only-p ;; contract-stats #:number-of-sold-sqm - #:paying-sponsors + #:number-of-paying-sponsors #:contract-stats-for-country #:last-paid-contracts Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-17 12:19:24 UTC (rev 3484) +++ trunk/projects/bos/m2/poi.lisp 2008-07-17 12:22:38 UTC (rev 3485) @@ -127,9 +127,8 @@ (defun make-poi-javascript (language) "Erzeugt das POI-Javascript für das Infosystem" (with-output-to-string (*standard-output*) - (format t "var anzahlSponsoren = ~D;~%" (count-if (lambda (sponsor) (some #'contract-paidp (sponsor-contracts sponsor))) - (class-instances 'sponsor))) - (format t "var anzahlVerkauft = ~D;~%" (bos.m2::number-of-sold-sqm)) + (format t "var anzahlSponsoren = ~D;~%" (number-of-paying-sponsors)) + (format t "var anzahlVerkauft = ~D;~%" (number-of-sold-sqm)) (format t "var pois = new Array;~%") (dolist (poi (sort (remove-if #'(lambda (poi) (or (not (poi-complete poi language)) (not (poi-published poi))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/m2.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3484 Author: ksprotte URL: http://bknr.net/trac/changeset/3484 again indentation U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 12:18:34 UTC (rev 3483) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 12:19:24 UTC (rev 3484) @@ -161,7 +161,7 @@ "Return a unique number to use when generating a sponsor. Uniqueness is guaranteed only across the running time of the process." (bknr.datastore::mp-with-lock-held (*sponsor-counter-lock*) - (incf *sponsor-counter*))) + (incf *sponsor-counter*))) (defun make-sponsor (&rest initargs &key login &allow-other-keys) (apply #'make-object 'sponsor

1 0

[bknr-cvs] ksprotte changed trunk/bknr/datastore/src/utils/acl-mp-compat.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3483 Author: ksprotte URL: http://bknr.net/trac/changeset/3483 better to use &body body (and not &rest) for two with-* macros U trunk/bknr/datastore/src/utils/acl-mp-compat.lisp Modified: trunk/bknr/datastore/src/utils/acl-mp-compat.lisp =================================================================== --- trunk/bknr/datastore/src/utils/acl-mp-compat.lisp 2008-07-17 12:15:06 UTC (rev 3482) +++ trunk/bknr/datastore/src/utils/acl-mp-compat.lisp 2008-07-17 12:18:34 UTC (rev 3483) @@ -17,7 +17,7 @@ #+lispworks (mp:make-lock :name name)) -(defmacro mp-with-lock-held ((lock) &rest body) +(defmacro mp-with-lock-held ((lock) &body body) #+allegro `(mp:with-process-lock (,lock) ,@body) @@ -34,7 +34,7 @@ `(mp:with-lock (,lock) ,@body)) -(defmacro mp-with-recursive-lock-held ((lock) &rest body) +(defmacro mp-with-recursive-lock-held ((lock) &body body) #+allegro `(mp:with-process-lock (,lock) ,@body)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/m2.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3482 Author: ksprotte URL: http://bknr.net/trac/changeset/3482 just indentation, sorry U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 12:10:43 UTC (rev 3481) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 12:15:06 UTC (rev 3482) @@ -161,7 +161,7 @@ "Return a unique number to use when generating a sponsor. Uniqueness is guaranteed only across the running time of the process." (bknr.datastore::mp-with-lock-held (*sponsor-counter-lock*) - (incf *sponsor-counter*))) + (incf *sponsor-counter*))) (defun make-sponsor (&rest initargs &key login &allow-other-keys) (apply #'make-object 'sponsor @@ -398,37 +398,37 @@ (labels ( ;; to-orig (distance-to-orig (d) (when-scaling-needed d - (round (* d scaler)))) + (round (* d scaler)))) (x-coordinate-to-orig (x) (when-scaling-needed x - (+ left (round (* (- x left) scaler))))) + (+ left (round (* (- x left) scaler))))) (y-coordinate-to-orig (y) (when-scaling-needed y - (+ top (round (* (- y top) scaler))))) + (+ top (round (* (- y top) scaler))))) (rectangle-to-orig (r) (when-scaling-needed r - (geometry:with-rectangle r - (list (x-coordinate-to-orig left) - (y-coordinate-to-orig top) - (distance-to-orig width) - (distance-to-orig height))))) + (geometry:with-rectangle r + (list (x-coordinate-to-orig left) + (y-coordinate-to-orig top) + (distance-to-orig width) + (distance-to-orig height))))) ;; from-orig (distance-from-orig (d) (when-scaling-needed d - (floor d scaler))) + (floor d scaler))) (x-coordinate-from-orig (x) (when-scaling-needed x - (+ left (floor (- x left) scaler)))) + (+ left (floor (- x left) scaler)))) (y-coordinate-from-orig (y) (when-scaling-needed y - (+ top (floor (- y top) scaler)))) + (+ top (floor (- y top) scaler)))) (rectangle-from-orig (r) (when-scaling-needed r - (geometry:with-rectangle r - (list (x-coordinate-from-orig left) - (y-coordinate-from-orig top) - (distance-from-orig width) - (distance-from-orig height)))))) + (geometry:with-rectangle r + (list (x-coordinate-from-orig left) + (y-coordinate-from-orig top) + (distance-from-orig width) + (distance-from-orig height)))))) (rectangle-to-orig (screamer-user:largest-rectangle (rectangle-from-orig bounding-box)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/m2.lisp
by BKNR Commits 17 Jul '08

17 Jul '08

Revision: 3481 Author: ksprotte URL: http://bknr.net/trac/changeset/3481 better name: number-of-paying-sponsors U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 12:06:29 UTC (rev 3480) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 12:10:43 UTC (rev 3481) @@ -625,7 +625,7 @@ (defun number-of-sold-sqm () (contract-stats-sold-m2s *contract-stats*)) -(defun paying-sponsors () +(defun number-of-paying-sponsors () (contract-stats-paying-sponsors *contract-stats*)) (defun contract-stats-for-country (country)

1 0