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

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

18 Jan '08

Author: ksprotte Date: Fri Jan 18 13:50:57 2008 New Revision: 2362 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/bos.m2.asd branches/bos/projects/bos/m2/packages.lisp Log: using awhen from arnesi for allocation cache 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 Fri Jan 18 13:50:57 2008 @@ -78,7 +78,7 @@ (setf (aref array next-x next-y) nil)) (do-neighbour-coordinates next-x next-y (x y) (when (and (in-array-bounds-p array x y) - (free-spot-p array x y)) + (free-spot-p array x y)) (collect (aref array x y)) (setf (aref array x y) nil) (point-stack-push x y stack))))) @@ -148,15 +148,12 @@ is decremented." (cond ((not (size-indexed-p n)) nil) - (remove (let ((cache-entry (index-pop n))) - (when cache-entry - (with-slots (area region) - cache-entry - (decf (allocation-area-free-m2s area) n) - region)))) - (t (let ((cache-entry (index-lookup n))) - (when cache-entry - (cache-entry-region cache-entry)))))) + (remove (awhen (index-pop n) + (with-slots (area region) it + (decf (allocation-area-free-m2s area) n) + region))) + (t (awhen (index-lookup n) + (cache-entry-region it))))) (defun add-area (allocation-area) (dolist (region (free-regions allocation-area) @@ -176,7 +173,7 @@ (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) - (for region-count = (length regions)) + (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*))) @@ -191,7 +188,7 @@ (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) (for size upfrom 1) - (for region-count = (length regions)) + (for region-count = (length regions)) (unless (zerop region-count) (leave size)))) @@ -199,7 +196,7 @@ (defclass allocation-cache-subsystem () ()) -(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) &key until) +(defmethod bknr.datastore::restore-subsystem + (store (subsystem allocation-cache-subsystem) &key until) (declare (ignore until)) (rebuild-cache)) - Modified: branches/bos/projects/bos/m2/bos.m2.asd ============================================================================== --- branches/bos/projects/bos/m2/bos.m2.asd (original) +++ branches/bos/projects/bos/m2/bos.m2.asd Fri Jan 18 13:50:57 2008 @@ -1,7 +1,7 @@ (in-package :cl-user) (asdf:defsystem :bos.m2 - :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate) + :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate :arnesi) :components ((:file "packages") (:file "config" :depends-on ("packages")) (:file "utils" :depends-on ("config")) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 13:50:57 2008 @@ -216,12 +216,10 @@ (intern "POINT-IN-POLYGON-P" :bos.m2) (defpackage :bos.m2.allocation-cache - (:use :cl - :bknr.utils + (:use :cl :bknr.indices :bknr.datastore - :bknr.user - :bknr.web + :bknr.user :bknr.images :bknr.statistics :bknr.rss

1 0

[bknr-cvs] r2361 - in branches/bos/projects/bos: m2 test
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 13:25:24 2008 New Revision: 2361 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/test/allocation-area.lisp Log: all tests pass!! 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 Fri Jan 18 13:25:24 2008 @@ -104,6 +104,8 @@ (in top (collect region))))))) ;;; allocation-cache +(defvar *allocation-cache*) + (defconstant +threshold+ 200 "Free regions of size N where (<= 1 N +threshold+) are indexed.") @@ -114,22 +116,23 @@ (defun make-allocation-cache () (make-instance 'allocation-cache)) -(defvar *allocation-cache*) +(defstruct cache-entry + area region) (declaim (inline index-lookup index-pop index-push size-indexed-p)) (defun index-lookup (n) - "Will return the first index region of size N or + "Will return the first index cache-entry of size N or nil if it does not exist." (first (aref (allocation-cache-index *allocation-cache*) (1- n)))) (defun index-pop (n) - "As INDEX-LOOKUP, but will remove the region + "As INDEX-LOOKUP, but will remove the cache-entry from the index." (pop (aref (allocation-cache-index *allocation-cache*) (1- n)))) -(defun index-push (n region) - "Add region (which has to be of size N) to index." - (push region (aref (allocation-cache-index *allocation-cache*) (1- n)))) +(defun index-push (n cache-entry) + "Add cache-entry (which has to be of size N) to index." + (push cache-entry (aref (allocation-cache-index *allocation-cache*) (1- n)))) (defun size-indexed-p (n) "Are regions of size N indexed?" @@ -141,18 +144,27 @@ matching N can be found, simply returns NIL. If REMOVE is T then the returned region is removed from -the cache." +the cache and FREE-M2S of the affected allocation-area +is decremented." (cond ((not (size-indexed-p n)) nil) - (remove (index-pop n)) - (t (index-lookup n)))) + (remove (let ((cache-entry (index-pop n))) + (when cache-entry + (with-slots (area region) + cache-entry + (decf (allocation-area-free-m2s area) n) + region)))) + (t (let ((cache-entry (index-lookup n))) + (when cache-entry + (cache-entry-region cache-entry)))))) (defun add-area (allocation-area) (dolist (region (free-regions allocation-area) allocation-area) (let ((size (length region))) (if (size-indexed-p size) - (index-push size region) + (index-push size (make-cache-entry :area allocation-area + :region region)) (incf (ignored-size *allocation-cache*) size))))) (defun free-regions-count () Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 13:25:24 2008 @@ -227,7 +227,8 @@ :bknr.rss :bos.m2 :bos.m2.config - :iterate) + :iterate + :arnesi) (:import-from :bos.m2 bos.m2::point-in-polygon-p) (:export #:find-exact-match #:add-area Modified: branches/bos/projects/bos/test/allocation-area.lisp ============================================================================== --- branches/bos/projects/bos/test/allocation-area.lisp (original) +++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 13:25:24 2008 @@ -18,11 +18,15 @@ (finishes (make-contract sponsor m2-count)) (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area)))))) -(test allocation-area.one-contract.with-cache +(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)) + (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))))))

1 0

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

18 Jan '08

Author: ksprotte Date: Fri Jan 18 12:43:06 2008 New Revision: 2360 Modified: branches/bos/projects/bos/m2/allocation.lisp Log: issue rebuild-cache on de- / activate-allocation-area Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Fri Jan 18 12:43:06 2008 @@ -184,11 +184,13 @@ (defun activate-allocation-area (area) (warn "activating ~S" area) (setf (slot-value area 'active-p) t) + (bos.m2.allocation-cache:rebuild-cache) area) (defun deactivate-allocation-area (area) (warn "deactivating ~S" area) (setf (slot-value area 'active-p) nil) + (bos.m2.allocation-cache:rebuild-cache) area) (defun map-edges (fn vertices)

1 0

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

18 Jan '08

Author: ksprotte Date: Fri Jan 18 12:41:19 2008 New Revision: 2359 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp Log: allocation-cache uses now ensure-m2 instead of get-m2 to retrieve a m2 instance for a point that is inside the polygon 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 Fri Jan 18 12:41:19 2008 @@ -29,7 +29,7 @@ (loop for y from top upto (1- (+ top height)) do (loop for x from left upto (1- (+ left width)) for spot = (when (point-in-polygon-p x y vertices) - (get-m2 x y)) + (ensure-m2 x y)) for x0 = (- x left) for y0 = (- y top) do (setf (aref array x0 y0) spot)))

1 0

[bknr-cvs] r2358 - in branches/bos/projects/bos: . m2
by hhubner＠common-lisp.net 18 Jan '08

18 Jan '08

Author: hhubner Date: Fri Jan 18 11:50:57 2008 New Revision: 2358 Modified: branches/bos/projects/bos/Makefile branches/bos/projects/bos/build.lisp branches/bos/projects/bos/m2/config.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/mail-generator.lisp Log: suppress mail sending unless expressly enabled. Modified: branches/bos/projects/bos/Makefile ============================================================================== --- branches/bos/projects/bos/Makefile (original) +++ branches/bos/projects/bos/Makefile Fri Jan 18 11:50:57 2008 @@ -16,7 +16,7 @@ .PHONY: test test: bos.core - lisp -core bos.core -test -slime + lisp -core bos.core -run-tests -slime # various cleaning stuff .PHONY: cleancore Modified: branches/bos/projects/bos/build.lisp ============================================================================== --- branches/bos/projects/bos/build.lisp (original) +++ branches/bos/projects/bos/build.lisp Fri Jan 18 11:50:57 2008 @@ -29,7 +29,7 @@ (define-toggle-switch "nostart" *webserver* t) (define-toggle-switch "slime" *slime* nil) (define-toggle-switch "cert-daemon" *cert-daemon* nil) -(define-toggle-switch "test" *run-tests* nil) +(define-toggle-switch "run-tests" *run-tests* nil) (defun start-webserver () (apply #'bos.m2::reinit (read-configuration "m2.rc")) @@ -61,7 +61,7 @@ (format t "BOS Online-System~%") (when *run-tests* (asdf:oos 'asdf:load-op :bos.test) - (format t "Starting BOS tests...~%") + (format t "Starting BOS tests...~%") (eval (read-from-string "(5am:run! :bos.test)")) (terpri) (finish-output) @@ -73,13 +73,9 @@ (start-slime)) (when *webserver* (start-webserver)) - (cond - (*run-tests* - (asdf:oos 'asdf:load-op :bos.test) - (eval (read-from-string "(5am:run! :bos.test)"))) - (t (when (or *slime* *webserver*) - (mp::startup-idle-and-top-level-loops)) - (lisp::%top-level)))) + (when (or *slime* *webserver*) + (mp::startup-idle-and-top-level-loops)) + (lisp::%top-level)) (setf *default-pathname-defaults* #p"") (when (probe-file "bos.core") Modified: branches/bos/projects/bos/m2/config.lisp ============================================================================== --- branches/bos/projects/bos/m2/config.lisp (original) +++ branches/bos/projects/bos/m2/config.lisp Fri Jan 18 11:50:57 2008 @@ -68,4 +68,7 @@ (defparameter *manual-contract-expiry-time* (* 42 24 3600)) (defparameter *online-contract-expiry-time* (* 3600)) -(defvar *website-url* "http://change-me") \ No newline at end of file +(defvar *website-url* "http://change-me") + +;; Einschalten des Mail-Versands (normalerweise aus) +(defvar *enable-mails* nil) \ No newline at end of file Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 18 11:50:57 2008 @@ -445,9 +445,10 @@ #-(or allegro cmu sbcl) ...)) -(defun reinit (&key delete directory website-url) +(defun reinit (&key delete directory website-url enable-mails) (format t "~&; Startup Quadratmeterdatenbank...~%") (force-output) + (setf *enable-mails* enable-mails) (setf *website-url* website-url) (unless directory (error ":DIRECTORY parameter not set in m2.rc")) 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 Fri Jan 18 11:50:57 2008 @@ -14,21 +14,23 @@ (country->office-email (sponsor-country (contract-sponsor contract)))) (defun send-system-mail (&key (to *office-mail-address*) (subject "(no subject") (text "(no text)") (content-type "text/plain; charset=UTF-8") more-headers) - (send-smtp "localhost" *mail-sender* to - (format nil "X-Mailer: BKNR-BOS-mailer + (if *enable-mails* + (send-smtp "localhost" *mail-sender* to + (format nil "X-Mailer: BKNR-BOS-mailer Date: ~A From: ~A To: ~A Subject: ~A ~@[Content-Type: ~A ~]~@[~*~%~]~A" - (format-date-time (get-universal-time) :mail-style t) - *mail-sender* - to - subject - content-type - (not more-headers) - text))) + (format-date-time (get-universal-time) :mail-style t) + *mail-sender* + to + subject + content-type + (not more-headers) + text)) + (format t "Mail with subject ~S to ~A not sent~%" subject to))) (defun mail-info-request (email country) (send-system-mail :subject "Mailing list request"

1 0

[bknr-cvs] r2357 - in branches/bos/projects/bos: m2 test
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 11:44:59 2008 New Revision: 2357 Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/bos.m2.asd branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/test/allocation-area.lisp branches/bos/projects/bos/test/fixtures.lisp Log: added allocation-cache-subsystem 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 Fri Jan 18 11:44:59 2008 @@ -183,3 +183,11 @@ (unless (zerop region-count) (leave size)))) +;;; subsystem +(defclass allocation-cache-subsystem () + ()) + +(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) &key until) + (declare (ignore until)) + (rebuild-cache)) + Modified: branches/bos/projects/bos/m2/bos.m2.asd ============================================================================== --- branches/bos/projects/bos/m2/bos.m2.asd (original) +++ branches/bos/projects/bos/m2/bos.m2.asd Fri Jan 18 11:44:59 2008 @@ -1,21 +1,21 @@ (in-package :cl-user) (asdf:defsystem :bos.m2 - :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate) - :components ((:file "packages") - (:file "config" :depends-on ("packages")) - (:file "utils" :depends-on ("config")) - (:file "news" :depends-on ("poi")) - (:file "tiled-index" :depends-on ("config")) - (:file "mail-generator" :depends-on ("config")) - (:file "make-certificate" :depends-on ("config")) - (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator")) - (:file "contract-expiry" :depends-on ("m2")) - (:file "allocation" :depends-on ("m2")) - (:file "allocation-cache" :depends-on ("packages")) - (:file "poi" :depends-on ("utils" "allocation")) - (:file "bitmap" :depends-on ("allocation")) - (:file "import" :depends-on ("m2")) - (:file "map" :depends-on ("m2" "allocation")) - (:file "export" :depends-on ("m2")) - (:file "cert-daemon" :depends-on ("config")))) + :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate) + :components ((:file "packages") + (:file "config" :depends-on ("packages")) + (:file "utils" :depends-on ("config")) + (:file "news" :depends-on ("poi")) + (:file "tiled-index" :depends-on ("config")) + (:file "mail-generator" :depends-on ("config")) + (:file "make-certificate" :depends-on ("config")) + (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator")) + (:file "contract-expiry" :depends-on ("m2")) + (:file "allocation" :depends-on ("m2")) + (:file "allocation-cache" :depends-on ("packages")) + (:file "poi" :depends-on ("utils" "allocation")) + (:file "bitmap" :depends-on ("allocation")) + (:file "import" :depends-on ("m2")) + (:file "map" :depends-on ("m2" "allocation")) + (:file "export" :depends-on ("m2")) + (:file "cert-daemon" :depends-on ("config")))) Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 18 11:44:59 2008 @@ -462,7 +462,8 @@ :directory directory :subsystems (list (make-instance 'store-object-subsystem) (make-instance 'blob-subsystem - :n-blobs-per-directory 1000))) + :n-blobs-per-directory 1000) + (make-instance 'bos.m2.allocation-cache:allocation-cache-subsystem))) (format t "~&; Startup der Quadratmeterdatenbank done.~%") (force-output)) @@ -473,5 +474,7 @@ while (and (or (null percentage) (< (allocation-area-percent-used (first (class-instances 'allocation-area))) percentage)) (make-contract sponsor - (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30))) + (random-elt (cons (1+ (random 300)) + '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 + 10 10 10 10 10 30 30 30))) :paidp t)))) \ No newline at end of file Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 11:44:59 2008 @@ -233,5 +233,6 @@ #:add-area #:free-regions-count #:free-regions-pprint - #:rebuild-cache)) + #:rebuild-cache + #:allocation-cache-subsystem)) Modified: branches/bos/projects/bos/test/allocation-area.lisp ============================================================================== --- branches/bos/projects/bos/test/allocation-area.lisp (original) +++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 11:44:59 2008 @@ -10,10 +10,19 @@ (finishes (make-allocation-rectangle 0 0 100 100)) (signals (error) (make-allocation-rectangle 0 0 100 100)))) -(test allocation-area.one-contract +(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)) - (finishes (make-contract sponsor m2-count))))) + (finishes (make-contract sponsor m2-count)) + (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area)))))) + +(test allocation-area.one-contract.with-cache + (with-fixture empty-store () + (let ((area (make-allocation-rectangle 0 0 2 5)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (finishes (make-contract sponsor m2-count)) + (is (zerop (allocation-area-free-m2s area)))))) Modified: branches/bos/projects/bos/test/fixtures.lisp ============================================================================== --- branches/bos/projects/bos/test/fixtures.lisp (original) +++ branches/bos/projects/bos/test/fixtures.lisp Fri Jan 18 11:44:59 2008 @@ -1,10 +1,11 @@ (in-package :bos.test) -(def-fixture empty-store () - (bos.m2::reinit :delete t - :directory #p"/tmp/test-store.tmp/" - :website-url bos.m2::*website-url*) +(def-fixture empty-store () (unwind-protect - (&body) + (progn + (bos.m2::reinit :delete t + :directory #p"/tmp/test-store.tmp/" + :website-url bos.m2::*website-url*) + (&body)) (close-store)))

1 0

[bknr-cvs] r2356 - in branches/bos/projects/bos: . m2 test
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 11:03:44 2008 New Revision: 2356 Added: branches/bos/projects/bos/test/allocation-area.lisp branches/bos/projects/bos/test/fixtures.lisp Modified: branches/bos/projects/bos/Makefile branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/test/allocation-cache.lisp branches/bos/projects/bos/test/bos.test.asd branches/bos/projects/bos/test/packages.lisp branches/bos/projects/bos/test/suites.lisp Log: a few tests are place; some fail... Modified: branches/bos/projects/bos/Makefile ============================================================================== --- branches/bos/projects/bos/Makefile (original) +++ branches/bos/projects/bos/Makefile Fri Jan 18 11:03:44 2008 @@ -7,10 +7,15 @@ bos.core: cmucl.core build.sh load.lisp build.lisp ./build.sh +# run with slime +.PHONY: slime +slime: bos.core + lisp -core bos.core -slime + # test .PHONY: test -test: +test: bos.core lisp -core bos.core -test -slime # various cleaning stuff @@ -40,3 +45,8 @@ make cleancore make all +# TAGS + +TAGS: + find . -name '*.lisp' | xargs etags -a + Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 18 11:03:44 2008 @@ -451,6 +451,10 @@ (setf *website-url* website-url) (unless directory (error ":DIRECTORY parameter not set in m2.rc")) + (assert (and (null (pathname-name directory)) + (null (pathname-type directory))) + (directory) + ":DIRECTORY parameter is ~s (not a directory pathname)" directory) (when delete (delete-directory directory) (assert (not (probe-file directory)))) Added: branches/bos/projects/bos/test/allocation-area.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 11:03:44 2008 @@ -0,0 +1,19 @@ +(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))))) + +(test allocation-area.no-intersection + (with-fixture empty-store () + (finishes (make-allocation-rectangle 0 0 100 100)) + (signals (error) (make-allocation-rectangle 0 0 100 100)))) + +(test allocation-area.one-contract + (with-fixture empty-store () + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (finishes (make-contract sponsor m2-count))))) + Modified: branches/bos/projects/bos/test/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/test/allocation-cache.lisp (original) +++ branches/bos/projects/bos/test/allocation-cache.lisp Fri Jan 18 11:03:44 2008 @@ -1,9 +1,7 @@ (in-package :bos.test) (in-suite :bos.test.allocation-cache) -(test dummy - (is (= 1 1))) - -(test dummy.2 - (is (= 1 2))) +(test allocation-cache.present + (with-fixture empty-store () + (finishes (bos.m2.allocation-cache:find-exact-match 1)))) Modified: branches/bos/projects/bos/test/bos.test.asd ============================================================================== --- branches/bos/projects/bos/test/bos.test.asd (original) +++ branches/bos/projects/bos/test/bos.test.asd Fri Jan 18 11:03:44 2008 @@ -5,6 +5,8 @@ :depends-on (:bos.web :fiveam) :components ((:file "packages") (:file "suites" :depends-on ("packages")) - (:file "allocation-cache" :depends-on ("suites")) + (:file "fixtures" :depends-on ("packages")) + (:file "allocation-area" :depends-on ("suites" "fixtures")) + (:file "allocation-cache" :depends-on ("suites" "fixtures")) ;; (:file "utils" :depends-on ("config")) )) Added: branches/bos/projects/bos/test/fixtures.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/test/fixtures.lisp Fri Jan 18 11:03:44 2008 @@ -0,0 +1,10 @@ +(in-package :bos.test) + +(def-fixture empty-store () + (bos.m2::reinit :delete t + :directory #p"/tmp/test-store.tmp/" + :website-url bos.m2::*website-url*) + (unwind-protect + (&body) + (close-store))) + Modified: branches/bos/projects/bos/test/packages.lisp ============================================================================== --- branches/bos/projects/bos/test/packages.lisp (original) +++ branches/bos/projects/bos/test/packages.lisp Fri Jan 18 11:03:44 2008 @@ -13,6 +13,7 @@ :bknr.images :bknr.statistics :bknr.rss + :bos.m2 :bos.m2.config )) Modified: branches/bos/projects/bos/test/suites.lisp ============================================================================== --- branches/bos/projects/bos/test/suites.lisp (original) +++ branches/bos/projects/bos/test/suites.lisp Fri Jan 18 11:03:44 2008 @@ -3,6 +3,10 @@ (def-suite :bos.test :description "The root suite. Contains all tests.") +(def-suite :bos.test.allocation-area + :in :bos.test + :description "Some basic tests for allocation-area.") + (def-suite :bos.test.allocation-cache :in :bos.test :description "Tests for the newly introduced allocation-cache.")

1 0

[bknr-cvs] r2355 - in branches/bos/projects/bos: . test
by ksprotte＠common-lisp.net 18 Jan '08

18 Jan '08

Author: ksprotte Date: Fri Jan 18 10:05:07 2008 New Revision: 2355 Added: branches/bos/projects/bos/test/ branches/bos/projects/bos/test/allocation-cache.lisp branches/bos/projects/bos/test/bos.test.asd branches/bos/projects/bos/test/packages.lisp branches/bos/projects/bos/test/suites.lisp Modified: branches/bos/projects/bos/Makefile branches/bos/projects/bos/build.lisp Log: basic test-suite setup; run: make test Modified: branches/bos/projects/bos/Makefile ============================================================================== --- branches/bos/projects/bos/Makefile (original) +++ branches/bos/projects/bos/Makefile Fri Jan 18 10:05:07 2008 @@ -4,9 +4,16 @@ cmucl.core: lisp -load make-base-lisp.lisp -bos.core: cmucl.core +bos.core: cmucl.core build.sh load.lisp build.lisp ./build.sh +# test + +.PHONY: test +test: + lisp -core bos.core -test -slime + +# various cleaning stuff .PHONY: cleancore cleancore: rm -f cmucl.core Modified: branches/bos/projects/bos/build.lisp ============================================================================== --- branches/bos/projects/bos/build.lisp (original) +++ branches/bos/projects/bos/build.lisp Fri Jan 18 10:05:07 2008 @@ -2,7 +2,11 @@ (handler-bind ((style-warning #'muffle-warning)) (asdf:operate 'asdf:load-op :aserve) - (asdf:operate 'asdf:load-op :bos.web)) + (asdf:operate 'asdf:load-op :bos.web) + ;; FIXME: fuer das Deployment ? + ;; BOS tests + (asdf:operate 'asdf:load-op :fiveam) + (asdf:oos 'asdf:load-op :bos.test)) ;;; ;;; Lisp-Image fuer das Deployment dumpen @@ -25,6 +29,7 @@ (define-toggle-switch "nostart" *webserver* t) (define-toggle-switch "slime" *slime* nil) (define-toggle-switch "cert-daemon" *cert-daemon* nil) +(define-toggle-switch "test" *run-tests* nil) (defun start-webserver () (apply #'bos.m2::reinit (read-configuration "m2.rc")) @@ -54,6 +59,13 @@ (fix-dpd) (asdf:oos 'asdf:load-op :bos.web) (format t "BOS Online-System~%") + (when *run-tests* + (asdf:oos 'asdf:load-op :bos.test) + (format t "Starting BOS tests...~%") + (eval (read-from-string "(5am:run! :bos.test)")) + (terpri) + (finish-output) + (cl-user::quit)) (when *cert-daemon* (format t "; starting certificate generation daemon, slime and webserver not started~%") (bos.m2.cert-generator:cert-daemon)) @@ -61,9 +73,13 @@ (start-slime)) (when *webserver* (start-webserver)) - (if (or *slime* *webserver*) - (mp::startup-idle-and-top-level-loops)) - (lisp::%top-level)) + (cond + (*run-tests* + (asdf:oos 'asdf:load-op :bos.test) + (eval (read-from-string "(5am:run! :bos.test)"))) + (t (when (or *slime* *webserver*) + (mp::startup-idle-and-top-level-loops)) + (lisp::%top-level)))) (setf *default-pathname-defaults* #p"") (when (probe-file "bos.core") Added: branches/bos/projects/bos/test/allocation-cache.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/test/allocation-cache.lisp Fri Jan 18 10:05:07 2008 @@ -0,0 +1,9 @@ +(in-package :bos.test) +(in-suite :bos.test.allocation-cache) + +(test dummy + (is (= 1 1))) + +(test dummy.2 + (is (= 1 2))) + Added: branches/bos/projects/bos/test/bos.test.asd ============================================================================== --- (empty file) +++ branches/bos/projects/bos/test/bos.test.asd Fri Jan 18 10:05:07 2008 @@ -0,0 +1,10 @@ +(in-package :cl-user) + +(asdf:defsystem :bos.test + :description "BOS Online-System test-suite" + :depends-on (:bos.web :fiveam) + :components ((:file "packages") + (:file "suites" :depends-on ("packages")) + (:file "allocation-cache" :depends-on ("suites")) + ;; (:file "utils" :depends-on ("config")) + )) Added: branches/bos/projects/bos/test/packages.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/test/packages.lisp Fri Jan 18 10:05:07 2008 @@ -0,0 +1,18 @@ +(defpackage :bos.test + (:use :cl + :fiveam + :iterate + ;; maybe later + ;; :cl-ppcre + ;; :cl-interpol + :bknr.utils + :bknr.indices + :bknr.datastore + :bknr.user + :bknr.web + :bknr.images + :bknr.statistics + :bknr.rss + :bos.m2.config + )) + Added: branches/bos/projects/bos/test/suites.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/test/suites.lisp Fri Jan 18 10:05:07 2008 @@ -0,0 +1,9 @@ +(in-package :bos.test) + +(def-suite :bos.test + :description "The root suite. Contains all tests.") + +(def-suite :bos.test.allocation-cache + :in :bos.test + :description "Tests for the newly introduced allocation-cache.") +

1 0

[bknr-cvs] r2354 - in branches/bos/thirdparty: emacs/slime slime
by hhubner＠common-lisp.net 18 Jan '08

18 Jan '08

Author: hhubner Date: Fri Jan 18 07:07:26 2008 New Revision: 2354 Added: branches/bos/thirdparty/slime/ - copied from r2353, branches/bos/thirdparty/emacs/slime/ Removed: branches/bos/thirdparty/emacs/slime/ Log: move slime to thirdparty-toplevel (has been there, please don't move it to emacs/ again

1 0

[bknr-cvs] r2353 - in branches/bos: bknr/src/web projects/bos/web
by hhubner＠common-lisp.net 18 Jan '08

18 Jan '08

Author: hhubner Date: Fri Jan 18 07:05:32 2008 New Revision: 2353 Modified: branches/bos/bknr/src/web/handlers.lisp branches/bos/bknr/src/web/web-utils.lisp branches/bos/projects/bos/web/tags.lisp branches/bos/projects/bos/web/webserver.lisp Log: redirect with http response code 301 instead of 302, hoping that it will make google analytics happy Modified: branches/bos/bknr/src/web/handlers.lisp ============================================================================== --- branches/bos/bknr/src/web/handlers.lisp (original) +++ branches/bos/bknr/src/web/handlers.lisp Fri Jan 18 07:05:32 2008 @@ -259,7 +259,7 @@ ((to :initarg :to :reader redirect-handler-to :documentation "url to redirect to"))) (defmethod handle ((page-handler redirect-handler) req) - (redirect (redirect-handler-to page-handler) req)) + (redirect (redirect-handler-to page-handler) req *response-moved-permanently*)) (defclass random-redirect-handler (redirect-handler) ()) Modified: branches/bos/bknr/src/web/web-utils.lisp ============================================================================== --- branches/bos/bknr/src/web/web-utils.lisp (original) +++ branches/bos/bknr/src/web/web-utils.lisp Fri Jan 18 07:05:32 2008 @@ -16,8 +16,8 @@ (with-http-body (req *ent*) (html "The page you requested could not be found.")))) -(defun redirect (to req) - (with-bknr-http-response (req :response *response-found*) +(defun redirect (to req &optional (response-code *response-found*)) + (with-bknr-http-response (req :response response-code) (setf (reply-header-slot-value req :location) to) (with-http-body (req *ent*)))) Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Fri Jan 18 07:05:32 2008 @@ -176,4 +176,4 @@ "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.'); document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));") ((:script :type "text/javascript") - #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }"))) + (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }")))) Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Fri Jan 18 07:05:32 2008 @@ -94,7 +94,8 @@ (defmethod handle ((handler index-handler) req) (redirect (format nil "/~A/index" (or (find-browser-prefered-language req) *default-language*)) - req)) + req + *response-moved-permanently*)) (defclass infosystem-handler (page-handler) ())

1 0