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

[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

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

17 Jul '08

Revision: 3480 Author: ksprotte URL: http://bknr.net/trac/changeset/3480 oops, there was a bug in add-to-contract-stats U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 11:42:34 UTC (rev 3479) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 12:06:29 UTC (rev 3480) @@ -612,7 +612,9 @@ (when new-sponsor-p (incf paying-sponsors)) ;; country-sponsors - (let ((country-stat (gethash country country-sponsors (make-country-stat)))) + (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))

1 0

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

17 Jul '08

Revision: 3479 Author: ksprotte URL: http://bknr.net/trac/changeset/3479 added new cache contract-stats that allows for last-paid-contracts, but also new queries U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 09:08:08 UTC (rev 3478) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 11:42:34 UTC (rev 3479) @@ -295,7 +295,7 @@ (deftransaction contract-set-paidp (contract newval) (setf (contract-paidp contract) newval) (publish-contract-change contract) - (add-to-last-contracts-cache contract) + (add-to-contract-stats contract) (bknr.rss::add-item "news" contract)) (defmethod contract-price ((contract contract)) @@ -580,28 +580,67 @@ ;; use only CONTRACT-PAIDP, but mean CONTRACT-PUBLISHED-P (contract-paidp contract)) -(defvar *last-contracts-cache* nil) +;;; contract-stats (defconstant +last-contracts-cache-size+ 20) +(defvar *contract-stats*) -(defun last-paid-contracts () - (unless *last-contracts-cache* - (setf *last-contracts-cache* (subseq (append (sort (remove-if-not #'contract-paidp (class-instances 'contract)) - #'> :key #'contract-date) - (make-list +last-contracts-cache-size+)) - 0 +last-contracts-cache-size+))) - (remove-if #'object-destroyed-p *last-contracts-cache*)) +(defstruct country-stat + (sold-m2s 0) + (paying-sponsors 0)) -(defun add-to-last-contracts-cache (contract) - (last-paid-contracts) ; force cache initialization, should really be done by a eval-when - (push contract *last-contracts-cache*) - (setf (cdr (nthcdr (1- +last-contracts-cache-size+) *last-contracts-cache*)) nil)) +(defstruct contract-stats + (sold-m2s 0) + (paying-sponsors 0) + (country-sponsors (make-hash-table :test #'equal)) + (last-contracts (make-list +last-contracts-cache-size+))) +(defun initialize-contract-stats () + (setq *contract-stats* (make-contract-stats)) + (dolist (contract (class-instances 'contract)) + (add-to-contract-stats contract))) + +(defun add-to-contract-stats (contract) + (let* ((area (contract-area contract)) + (sponsor (contract-sponsor contract)) + (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor))) + (country (string-upcase (sponsor-country sponsor)))) + (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts) + *contract-stats* + ;; sold-m2s + (incf sold-m2s area) + ;; paying-sponsors + (when new-sponsor-p + (incf paying-sponsors)) + ;; country-sponsors + (let ((country-stat (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)))) + (defun number-of-sold-sqm () - (let ((retval 0)) - (dolist (contract (remove-if-not #'contract-paidp (class-instances 'contract))) - (incf retval (length (contract-m2s contract)))) - retval)) + (contract-stats-sold-m2s *contract-stats*)) +(defun paying-sponsors () + (contract-stats-paying-sponsors *contract-stats*)) + +(defun contract-stats-for-country (country) + (let ((stat (gethash country (contract-stats-country-sponsors *contract-stats*)))) + (if stat + (values (country-stat-paying-sponsors stat) + (country-stat-sold-m2s stat)) + (values 0 0)))) + +(defun last-paid-contracts () + (remove-if (lambda (contract) + (or (null contract) + (object-destroyed-p contract))) + (contract-stats-last-contracts *contract-stats*))) + +(register-store-transient-init-function 'initialize-contract-stats) + (defun string-safe (string) (if string (escape-nl (arnesi:escape-as-html string)) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-17 09:08:08 UTC (rev 3478) +++ trunk/projects/bos/m2/packages.lisp 2008-07-17 11:42:34 UTC (rev 3479) @@ -165,8 +165,13 @@ #:contract-pdf-pathname #:contract-pdf-url #:contract-download-only-p + ;; contract-stats + #:number-of-sold-sqm + #:paying-sponsors + #:contract-stats-for-country + #:last-paid-contracts + #:make-m2-javascript - #:last-paid-contracts #:recolorize-contracts #:contracts-well-colored-p #:contract-published-p Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-17 09:08:08 UTC (rev 3478) +++ trunk/projects/bos/m2/poi.lisp 2008-07-17 11:42:34 UTC (rev 3479) @@ -127,8 +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;~%" (length (remove-if-not #'(lambda (sponsor) (some #'contract-paidp (sponsor-contracts sponsor))) - (class-instances 'sponsor)))) + (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 pois = new Array;~%") (dolist (poi (sort (remove-if #'(lambda (poi) (or (not (poi-complete poi language))

1 0

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

17 Jul '08

Revision: 3478 Author: hans URL: http://bknr.net/trac/changeset/3478 Get PDF generation with M2 icon to work. U trunk/projects/bos/Makefile U trunk/projects/bos/m2/cert-daemon.lisp U trunk/projects/bos/m2/m2-pdf.lisp Modified: trunk/projects/bos/Makefile =================================================================== --- trunk/projects/bos/Makefile 2008-07-17 09:02:14 UTC (rev 3477) +++ trunk/projects/bos/Makefile 2008-07-17 09:08:08 UTC (rev 3478) @@ -2,7 +2,7 @@ .PHONY: all bos.core: build.lisp - sbcl --load build.lisp --eval '(sb-ext:save-lisp-and-die "bos.core")' + env LANG=en_US.UTF-8 sbcl --load build.lisp --eval '(sb-ext:save-lisp-and-die "bos.core")' # various cleaning stuff .PHONY: cleancore Modified: trunk/projects/bos/m2/cert-daemon.lisp =================================================================== --- trunk/projects/bos/m2/cert-daemon.lisp 2008-07-17 09:02:14 UTC (rev 3477) +++ trunk/projects/bos/m2/cert-daemon.lisp 2008-07-17 09:08:08 UTC (rev 3478) @@ -1,19 +1,13 @@ (in-package :bos.m2.cert-generator) -(defun run-tool (program &optional program-args &rest args) - (let* ((process (apply #'run-program program program-args :search t :output :stream args)) - (error-message (unless (zerop (process-exit-code process)) - (with-output-to-string (*standard-output*) - (with-open-stream (output-stream (process-output process)) - (princ (read-line output-stream nil))))))) - (process-close process) - (unless (zerop (process-exit-code process)) - (error "Error executing ~A - Exit code ~D~%Error message: ~A" - (format nil "\"~A~{ ~A~}\"" program program-args) (process-exit-code process) error-message)))) +(defun run-tool (program &rest args) + (let ((asdf::*verbose-out* t)) + (apply #'asdf:run-shell-command "~S ~{~S ~}" program args))) (defun fill-form (fdf-pathname pdf-pathname m2-pdf-pathname output-pathname) (handler-case - (with-temporary-file (temporary-pdf-pathname :defaults #P"/tmp/.pdf") + (with-temporary-file (temporary-pdf-pathname :defaults (make-pathname :directory '(:absolute "tmp") + :type "pdf")) (cond ((namestring pdf-pathname) (run-tool "pdftk" (list (namestring pdf-pathname) @@ -42,7 +36,7 @@ country)) template-pathname)) (m2-pdf-pathname (merge-pathnames - (make-pathname :name (format nil "~A-m2s" id)) + (make-pathname :name (format nil "~A-m2s" id) :type "pdf") fdf-pathname)) (output-pathname (merge-pathnames (make-pathname :name id :type "pdf") fdf-pathname))) (fill-form fdf-pathname Modified: trunk/projects/bos/m2/m2-pdf.lisp =================================================================== --- trunk/projects/bos/m2/m2-pdf.lisp 2008-07-17 09:02:14 UTC (rev 3477) +++ trunk/projects/bos/m2/m2-pdf.lisp 2008-07-17 09:08:08 UTC (rev 3478) @@ -58,7 +58,10 @@ (pdf:line-to x y) (pdf:close-fill-and-stroke))))))) - (with-open-file (f (contract-m2-pdf-pathname contract :print print) :direction :output :if-exists :supersede) + (with-open-file (f (contract-m2-pdf-pathname contract :print print) + :direction :output + :if-exists :supersede + :external-format :iso-8859-1) ;; cl-pdf does not really handle non-ascii characters in a very ;; usable manner. In order to avoid having to deal with ;; embedding fonts and encoding, just work around the issue:

1 0

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

17 Jul '08

Revision: 3477 Author: ksprotte URL: http://bknr.net/trac/changeset/3477 renamed add-contract-to-cache -> add-to-last-contracts-cache U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-17 07:45:32 UTC (rev 3476) +++ trunk/projects/bos/m2/m2.lisp 2008-07-17 09:02:14 UTC (rev 3477) @@ -295,7 +295,7 @@ (deftransaction contract-set-paidp (contract newval) (setf (contract-paidp contract) newval) (publish-contract-change contract) - (add-contract-to-cache contract) + (add-to-last-contracts-cache contract) (bknr.rss::add-item "news" contract)) (defmethod contract-price ((contract contract)) @@ -591,7 +591,7 @@ 0 +last-contracts-cache-size+))) (remove-if #'object-destroyed-p *last-contracts-cache*)) -(defun add-contract-to-cache (contract) +(defun add-to-last-contracts-cache (contract) (last-paid-contracts) ; force cache initialization, should really be done by a eval-when (push contract *last-contracts-cache*) (setf (cdr (nthcdr (1- +last-contracts-cache-size+) *last-contracts-cache*)) nil))

1 0

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

17 Jul '08

Revision: 3476 Author: ksprotte URL: http://bknr.net/trac/changeset/3476 dont run :bos.test on darwin U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-07-17 06:11:30 UTC (rev 3475) +++ trunk/build.lisp 2008-07-17 07:45:32 UTC (rev 3476) @@ -199,7 +199,7 @@ (unit-test:run-all-tests) (rt:do-tests) (fiveam-run-no-failures-p :bknr.datastore) - (fiveam-run-no-failures-p :bos.test) + #-darwin (fiveam-run-no-failures-p :bos.test) (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM) (warn "skipping :it.bese.FiveAM tests") t)

1 0

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

17 Jul '08

Revision: 3475 Author: hans URL: http://bknr.net/trac/changeset/3475 updates to transient slots no longer update LAST-CHANGE, so revert 3469 U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-17 06:09:00 UTC (rev 3474) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-17 06:11:30 UTC (rev 3475) @@ -164,12 +164,11 @@ (defmethod allocation-area-bounding-box ((allocation-area allocation-area)) (with-slots (left top width height bounding-box) allocation-area (unless (slot-boundp allocation-area 'bounding-box) - (with-transaction ("setf allocation-area bounding-box") - (setf bounding-box (coerce (list (cons left top) - (cons (+ left width) top) - (cons (+ left width) (+ top height)) - (cons left (+ top height))) - 'vector)))) + (setf bounding-box (coerce (list (cons left top) + (cons (+ left width) top) + (cons (+ left width) (+ top height)) + (cons left (+ top height))) + 'vector))) bounding-box)) (defmethod allocation-area-bounding-box2 ((allocation-area allocation-area))

1 0

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

17 Jul '08

Revision: 3474 Author: hans URL: http://bknr.net/trac/changeset/3474 Only update LAST-CHANGE slot if another persistent slot is changed. 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-16 18:11:24 UTC (rev 3473) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-17 06:09:00 UTC (rev 3474) @@ -89,8 +89,9 @@ (not (in-transaction-p))) (error "Attempt to set persistent slot ~A of ~A outside of a transaction" slot-name object)) - (unless (or (eq :restore (store-state *store*)) - (eq 'last-change slot-name)) + (when (and (persistent-slot-p slotd) + (not (eq :restore (store-state *store*))) + (not (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