bknr-cvs January 2008

bknr-cvs@common-lisp.net

3 participants
103 discussions

[bknr-cvs] r2384 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 22 Jan '08

22 Jan '08

Author: hhubner Date: Tue Jan 22 01:59:19 2008 New Revision: 2384 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp Log: Slightly beautify table. Please use upper case letters for format directives so that they are easier to identify visually. Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Tue Jan 22 01:59:19 2008 @@ -197,13 +197,15 @@ (summing (length regions)))) (defun pprint-cache () + (format t "~5A~10T~A~%" "size" "count") + (format t "~5A~10T~A~%" "-----" "-----") (iter - (for regions in-vector (allocation-cache-index *allocation-cache*)) + (for cache-entries in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) - (for region-count = (length regions)) - (unless (zerop region-count) - (format t "~a~10T~a~%" size region-count))) - (format t "area size ignored by cache: ~a~%" (ignored-size *allocation-cache*))) + (for count = (length cache-entries)) + (unless (zerop count) + (format t "~5D~10T~5D~%" size count))) + (format t "~%Area size ignored by cache: ~A~%" (ignored-size *allocation-cache*))) (defun rebuild-cache () (setq *allocation-cache* (make-allocation-cache))

1 0

[bknr-cvs] r2383 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 22 Jan '08

22 Jan '08

Author: hhubner Date: Tue Jan 22 01:58:29 2008 New Revision: 2383 Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp Log: Remove "disclaimer" Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/allocation-cache-handlers.lisp (original) +++ branches/bos/projects/bos/web/allocation-cache-handlers.lisp Tue Jan 22 01:58:29 2008 @@ -7,8 +7,7 @@ (defmethod handle ((handler allocation-cache-handler) req) (with-bos-cms-page (req :title "Allocation Cache") - (html - (:p (:i "not yet very meaningful...")) + (html (:pre (:princ (with-output-to-string (*standard-output*) (bos.m2.allocation-cache:pprint-cache)))))))

1 0

[bknr-cvs] r2382 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 22 Jan '08

22 Jan '08

Author: hhubner Date: Tue Jan 22 01:54:54 2008 New Revision: 2382 Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp Log: Fix output formatting so that line breaks actually make it into the generated HTML. Modified: branches/bos/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/allocation-cache-handlers.lisp (original) +++ branches/bos/projects/bos/web/allocation-cache-handlers.lisp Tue Jan 22 01:54:54 2008 @@ -9,7 +9,7 @@ (with-bos-cms-page (req :title "Allocation Cache") (html (:p (:i "not yet very meaningful...")) - (:pre (:princ-safe + (:pre (:princ (with-output-to-string (*standard-output*) (bos.m2.allocation-cache:pprint-cache)))))))

1 0

[bknr-cvs] r2381 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 12:30:43 2008 New Revision: 2381 Added: branches/bos/projects/bos/web/allocation-cache-handlers.lisp Modified: branches/bos/projects/bos/web/bos.web.asd branches/bos/projects/bos/web/webserver.lisp Log: added basic allocation-cache handler pre output not very meaningful yet due to missing linebreaks (?) Added: branches/bos/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/web/allocation-cache-handlers.lisp Mon Jan 21 12:30:43 2008 @@ -0,0 +1,15 @@ +(in-package :bos.web) + +(enable-interpol-syntax) + +(defclass allocation-cache-handler (admin-only-handler page-handler) + ()) + +(defmethod handle ((handler allocation-cache-handler) req) + (with-bos-cms-page (req :title "Allocation Cache") + (html + (:p (:i "not yet very meaningful...")) + (:pre (:princ-safe + (with-output-to-string (*standard-output*) + (bos.m2.allocation-cache:pprint-cache))))))) + Modified: branches/bos/projects/bos/web/bos.web.asd ============================================================================== --- branches/bos/projects/bos/web/bos.web.asd (original) +++ branches/bos/projects/bos/web/bos.web.asd Mon Jan 21 12:30:43 2008 @@ -33,6 +33,7 @@ (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-handlers" :depends-on ("web-utils")) + (:file "allocation-cache-handlers" :depends-on ("web-utils")) (:file "languages-handler" :depends-on ("web-utils")) (:file "tags" :depends-on ("web-utils")) (:file "news-tags" :depends-on ("web-utils")) Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Mon Jan 21 12:30:43 2008 @@ -210,6 +210,7 @@ ("/create-allocation-area" create-allocation-area-handler) ("/allocation-area" allocation-area-handler) ("/allocation-area-gfx" allocation-area-gfx-handler) + ("/allocation-cache" allocation-cache-handler) ("/contract-image" contract-image-handler) ("/certificate" certificate-handler) ("/cert-regen" cert-regen-handler) @@ -239,7 +240,8 @@ ("logout" . "logout")) :admin-navigation '(("user" . "user/") ("languages" . "languages") - ("allocation area" . "allocation-area/")) + ("allocation area" . "allocation-area/") + ("allocation cache" . "allocation-cache")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css")

1 0

[bknr-cvs] r2380 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 11:36:19 2008 New Revision: 2380 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/packages.lisp Log: renamed allocation-cache functions Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Mon Jan 21 11:36:19 2008 @@ -191,12 +191,12 @@ :region region)) (incf (ignored-size *allocation-cache*) size))))) -(defun free-regions-count () +(defun count-cache-entries () (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (summing (length regions)))) -(defun free-regions-pprint () +(defun pprint-cache () (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 11:36:19 2008 @@ -25,7 +25,7 @@ (bos.m2::activate-allocation-area area)) (with-store-reopenings (area sponsor) (finishes (allocation-area-free-m2s area)) - (is (= 1 (bos.m2.allocation-cache:free-regions-count))) + (is (= 1 (bos.m2.allocation-cache:count-cache-entries))) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Mon Jan 21 11:36:19 2008 @@ -237,8 +237,8 @@ :arnesi) (:export #:find-exact-match #:add-area - #:free-regions-count - #:free-regions-pprint + #:count-cache-entries + #:pprint-cache #:rebuild-cache #:allocation-cache-subsystem))

1 0

[bknr-cvs] r2379 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 21 Jan '08

21 Jan '08

Author: hhubner Date: Mon Jan 21 11:18:10 2008 New Revision: 2379 Modified: branches/bos/projects/bos/m2/mail-generator.lisp Log: Ignore errors while deleting print certificate. Modified: branches/bos/projects/bos/m2/mail-generator.lisp ============================================================================== --- branches/bos/projects/bos/m2/mail-generator.lisp (original) +++ branches/bos/projects/bos/m2/mail-generator.lisp Mon Jan 21 11:18:10 2008 @@ -222,7 +222,7 @@ :subtype "mixed" :content parts) t t)))) - (when (contract-pdf-pathname contract :print t) + (ignore-errors (delete-file (contract-pdf-pathname contract :print t)))) (defun mail-print-pdf (contract) @@ -248,7 +248,8 @@ :encoding :base64 :content (file-contents (contract-pdf-pathname contract :print t))))) t t))) - (delete-file (contract-pdf-pathname contract :print t))) + (ignore-errors + (delete-file (contract-pdf-pathname contract :print t)))) (defun mail-backoffice-sponsor-data (contract req) (with-query-params (req numsqm country email name address date language)

1 0

[bknr-cvs] r2378 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 10:39:51 2008 New Revision: 2378 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/allocation.lisp branches/bos/projects/bos/m2/packages.lisp Log: allocation-cache now updated for RETURN-M2S Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Mon Jan 21 10:39:51 2008 @@ -219,6 +219,15 @@ (unless (zerop region-count) (leave size)))) +(defmethod return-m2s :after (m2s) + ;; bos.m2::m2-allocation-area is quite + ;; expensive... + ;; (assert (every #'(lambda (m2) (eq (bos.m2::m2-allocation-area (first m2s)) (bos.m2::m2-allocation-area m2))) + ;; (rest m2s))) + (let ((allocation-area (bos.m2::m2-allocation-area (first m2s)))) + (index-push (length m2s) (make-cache-entry :area allocation-area + :region m2s)))) + ;;; subsystem (defclass allocation-cache-subsystem () ()) Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 10:39:51 2008 @@ -55,3 +55,39 @@ (is (= (- 64 10) (allocation-area-free-m2s area))) (signals (error) (make-contract sponsor 64))))) +(store-test allocation-area.return-m2s + (let* ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor")) + (contract (make-contract sponsor 64))) + (with-store-reopenings (area sponsor contract) + (is (zerop (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64)) + (with-transaction () + (destroy-object contract)) + (is-true (bos.m2.allocation-cache:find-exact-match 64)) + (finishes (make-contract sponsor 10)) + (is (= (- (* 8 8) 10) (allocation-area-free-m2s area)))))) + +(test allocation-area.two-areas + (with-fixture empty-store () + (let ((snapshot nil) (bypass t)) + (declare (ignorable snapshot bypass)) + (let* ((area1 (make-allocation-rectangle 0 0 8 8)) + (area2 (make-allocation-rectangle 10 10 8 8)) + (sponsor (make-sponsor :login "test-sponsor")) + (total-free (+ 64 64))) + (progn + (iter (while (> total-free 20)) + (bos.m2.allocation-cache:rebuild-cache) + (for size = (1+ (random 3))) + (is (= total-free (+ (allocation-area-free-m2s area1) + (allocation-area-free-m2s area2)))) + (with-transaction () + (iter + (while (> size total-free)) + (for contract = (first (class-instances 'contract))) + (incf total-free (length (contract-m2s contract))) + (destroy-object contract))) + (finishes (make-contract sponsor size)) + (decf total-free size))))))) + Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Mon Jan 21 10:39:51 2008 @@ -641,7 +641,7 @@ (warn "all allocation areas exhausted") nil)) -(defun return-m2s (m2s) +(defmethod return-m2s (m2s) "Mark the given square meters as free, so that they can be re-allocated." (when m2s (loop for m2 in m2s Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Mon Jan 21 10:39:51 2008 @@ -87,6 +87,7 @@ #:m2-utm-x #:m2-utm-y #:escape-nl + #:return-m2s #:sponsor #:make-sponsor

1 0

[bknr-cvs] r2377 - branches/bos/projects/bos/m2
by hhubner＠common-lisp.net 21 Jan '08

21 Jan '08

Author: hhubner Date: Mon Jan 21 09:14:09 2008 New Revision: 2377 Modified: branches/bos/projects/bos/m2/test-fixtures.lisp Log: &rest statt &body Modified: branches/bos/projects/bos/m2/test-fixtures.lisp ============================================================================== --- branches/bos/projects/bos/m2/test-fixtures.lisp (original) +++ branches/bos/projects/bos/m2/test-fixtures.lisp Mon Jan 21 09:14:09 2008 @@ -9,7 +9,7 @@ :website-url bos.m2::*website-url*) (format t "~&;; ++ reopen-store done~%")) -(defmacro reopen-store ((&key snapshot) &body store-object-vars) +(defmacro reopen-store ((&key snapshot) &rest store-object-vars) (let ((id-vars (iter (with *print-case* = :upcase) (for store-object-var in store-object-vars)

1 0

[bknr-cvs] r2376 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 09:03:34 2008 New Revision: 2376 Removed: branches/bos/projects/bos/m2/allocation-cache-test.lisp Modified: branches/bos/projects/bos/m2/bos.test.asd Log: no need to have separate allocation-cache-test.lisp Modified: branches/bos/projects/bos/m2/bos.test.asd ============================================================================== --- branches/bos/projects/bos/m2/bos.test.asd (original) +++ branches/bos/projects/bos/m2/bos.test.asd Mon Jan 21 09:03:34 2008 @@ -6,7 +6,6 @@ :components ((:file "packages-test") (:file "test-suites" :depends-on ("packages-test")) (:file "test-fixtures" :depends-on ("packages-test")) - (:file "allocation-test" :depends-on ("test-suites" "test-fixtures")) - (:file "allocation-cache-test" :depends-on ("test-suites" "test-fixtures")) + (:file "allocation-test" :depends-on ("test-suites" "test-fixtures")) ;; (:file "utils" :depends-on ("config")) ))

1 0

[bknr-cvs] r2375 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 21 Jan '08

21 Jan '08

Author: ksprotte Date: Mon Jan 21 08:59:03 2008 New Revision: 2375 Modified: branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/test-fixtures.lisp Log: now using STORE-TEST + WITH-STORE-REOPENINGS to define tests Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 08:59:03 2008 @@ -1,50 +1,56 @@ (in-package :bos.test) (in-suite :bos.test.allocation-area) -(test allocation-area.none-at-startup - (with-fixture empty-store () - (is (null (class-instances 'bos.m2:allocation-area))))) +(store-test allocation-area.none-at-startup + (is (null (class-instances 'bos.m2:allocation-area)))) -(test allocation-area.no-intersection - (with-fixture empty-store () +(store-test allocation-area.no-intersection + (with-store-reopenings () (finishes (make-allocation-rectangle 0 0 100 100)) (signals (error) (make-allocation-rectangle 0 0 100 100)))) -(test allocation-area.one-contract.no-cache - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 100 100)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count 10)) +(store-test allocation-area.one-contract.no-cache + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor m2-count)) (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.with-cache.1 - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 2 5)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count 10)) - (with-transaction () - (bos.m2::activate-allocation-area area)) +(store-test allocation-area.one-contract.with-cache.1 + (let ((area (make-allocation-rectangle 0 0 2 5)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (with-transaction () + (bos.m2::activate-allocation-area area)) + (with-store-reopenings (area sponsor) (finishes (allocation-area-free-m2s area)) - (is (= 1 (bos.m2.allocation-cache:free-regions-count))) - (reopen-store (:snapshot nil) area sponsor) + (is (= 1 (bos.m2.allocation-cache:free-regions-count))) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.allocate-all-without-cache - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 100 100)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count (* 100 100))) +(store-test allocation-area.one-contract.allocate-all-without-cache + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count (* 100 100))) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor m2-count)) (signals (error) (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.notany-m2-contract - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 8 8)) - (sponsor (make-sponsor :login "test-sponsor"))) +(store-test allocation-area.one-contract.notany-m2-contract + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (with-store-reopenings (area sponsor) + (finishes (make-contract sponsor 10)) + (is (= (- 64 10) (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64))))) + +(store-test allocation-area.one-contract.notany-m2-contract + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor 10)) (is (= (- 64 10) (allocation-area-free-m2s area))) (signals (error) (make-contract sponsor 64))))) Modified: branches/bos/projects/bos/m2/test-fixtures.lisp ============================================================================== --- branches/bos/projects/bos/m2/test-fixtures.lisp (original) +++ branches/bos/projects/bos/m2/test-fixtures.lisp Mon Jan 21 08:59:03 2008 @@ -26,6 +26,22 @@ (collect store-object-var) (collect `(find-store-object ,id-var))))))) +(defmacro %with-store-reopenings ((&key snapshot bypass) + (&rest store-object-vars) &body body) + `(progn + ,@(if bypass + body + (iter + (for form in body) + (unless (first-time-p) + (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) + (collect form))))) + +(defmacro with-store-reopenings ((&rest store-object-vars) &body body) + `(%with-store-reopenings (:snapshot snapshot :bypass bypass) + (,@store-object-vars) + ,@body)) + (def-fixture empty-store () (unwind-protect (progn @@ -35,3 +51,19 @@ (&body)) (close-store))) +(defmacro store-test (name &body body) + `(progn + ,@(iter + (for config in '((:suffix reopenings-no-snapshot :snapshot nil :bypass nil) + (:suffix reopenings-with-snapshot :snapshot t :bypass nil) + (:suffix nil :snapshot nil :bypass t))) + (for test-name = (if (getf config :suffix) + (intern (format nil "~a.~a" name (getf config :suffix))) + name)) + (collect `(test ,test-name + (with-fixture empty-store () + (let ((snapshot ,(getf config :snapshot)) + (bypass ,(getf config :bypass))) + (declare (ignorable snapshot bypass)) + ,@body))))))) +

1 0

← Newer
1
2
3
4
5
6
7
8
9
10
11
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs January 2008