bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

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

17 Jul '08

Revision: 3493 Author: ksprotte URL: http://bknr.net/trac/changeset/3493 removed obsolete image-tree from bos - step 2 U trunk/projects/bos/web/bos.web.asd D trunk/projects/bos/web/image-tree.lisp A trunk/projects/bos/web/kml-utils.lisp Change set too large, please see URL above

1 0

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

17 Jul '08

Revision: 3492 Author: ksprotte URL: http://bknr.net/trac/changeset/3492 removed obsolete image-tree from bos - step 1 U trunk/projects/bos/web/image-tree.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/image-tree.lisp =================================================================== --- trunk/projects/bos/web/image-tree.lisp 2008-07-17 14:48:01 UTC (rev 3491) +++ trunk/projects/bos/web/image-tree.lisp 2008-07-17 15:17:01 UTC (rev 3492) @@ -312,371 +312,3 @@ ;; end kml utils -(defvar *image-tree-node-counter*) - -(defmacro with-image-tree-node-counter (&body body) - "Allows to call IMAGE-TREE-NODE-UNIQUE-NAME in BODY." - `(let ((*image-tree-node-counter* -1)) - ,@body)) - -(defun image-tree-node-unique-name () - "Generates a unique name for an image-tree-node." - (format nil "image-tree-~a-~a-~a" (get-universal-time) (random 10000) (incf *image-tree-node-counter*))) - -(defpersistent-class image-tree-node (store-image) - ((geo-x :initarg :geo-x :reader geo-x) - (geo-y :initarg :geo-y :reader geo-y) - (geo-width :initarg :geo-width :reader geo-width) - (geo-height :initarg :geo-height :reader geo-height) - (children :initarg :children :reader children) - (parent :reader parent) - (depth :accessor depth :initarg :depth)) - (:documentation "Derived from STORE-IMAGE, IMAGE-TREE-NODE is an -image itself, which has additional information, like its -geo-location. It also knows about its position in the tree; being at a -certain DEPTH and pointing to its PARENT and its CHILDREN.")) - -(defpersistent-class image-tree (image-tree-node) - ((parent :initform nil)) - (:documentation "IMAGE-TREE is the root node of IMAGE-TREE-NODEs.")) - -(defmethod print-object ((object image-tree-node) stream) - (print-unreadable-object (object stream :type t) - (format stream "ID: ~A (~A x ~A)" - (store-object-id object) - (store-image-width object) - (store-image-height object)))) - -(defmethod initialize-persistent-instance :after ((obj image-tree-node)) - ;; initialize the parent slot - (dolist (child (children obj)) - (setf (slot-value child 'parent) obj))) - -(defmethod geo-location ((obj image-tree-node)) - (list (geo-x obj) (geo-y obj) (geo-width obj) (geo-height obj))) - -(defun make-image-tree-node (image &key geo-rect children - (class-name 'image-tree-node) - depth) - (destructuring-bind (geo-x geo-y geo-width geo-height) - geo-rect - (make-store-image :image image - :name (image-tree-node-unique-name) - :class-name class-name - :initargs `(:geo-x ,geo-x - :geo-y ,geo-y - :geo-width ,geo-width - :geo-height ,geo-height - :children ,children - :depth ,depth)))) - -(defun image-tree-node-less (a b) - "Allows to give IMAGE-TREE-NODEs a canonical order according to -their geo-locations." - (cond - ((< (geo-x a) (geo-x b)) t) - ((= (geo-x a) (geo-x b)) - (< (geo-y a) (geo-y b))) - (t nil))) - -;; (defmethod lod-min ((obj image-tree-node)) -;; (/ (min (store-image-width obj) (store-image-height obj)) 2.0)) - -;; (defmethod lod-min ((obj image-tree)) -;; 900) - -;; (defmethod lod-max ((obj image-tree-node)) -;; (if (children obj) -;; (* (store-image-width obj) (store-image-height obj)) -;; -1)) - -(defmethod lod-min ((obj image-tree-node)) - "Initially intended to customize LOD-MIN according to the node's -context. It seems that a constant default value is sufficient here." - 256) - -(defmethod lod-min ((obj image-tree)) - 16) - -(defmethod lod-max ((obj image-tree-node)) - "See LOD-MIN." - -1) - -(defun children-sizes (width height &key (divisor 2)) - "Splits a rectangle of integer size WIDTH x HEIGHT into almost equal -parts that have again integer size. If the initial rectangle does not -have an extreme aspect ratio, the number of the resulting rectangles -will be (sqr divisor)." - ;; extreme aspect ratios are not implemented yet - (flet ((divide-almost-equally (x) - (multiple-value-bind (quotient remainder) - (floor x divisor) - (loop for i from 0 below divisor - if (zerop i) - collect (+ quotient remainder) - else - collect quotient)))) - (list (divide-almost-equally width) - (divide-almost-equally height)))) - -(defun map-children-rects (function left top width-heights depth) - "Calls FUNCTION with (x y width height depth) for each of the -sub-rectangles specified by the start point LEFT, TOP and -WIDTH-HEIGHTS of the sub-rectangles. Collects the results into an -array of dimensions corresponding to WIDTH-HEIGHTS." - (let (results) - (destructuring-bind (widths heights) - width-heights - (dolist (w widths (nreverse results)) - (let ((safe-top top)) ; pretty ugly, sorry - (dolist (h heights) - (push (funcall function left safe-top w h depth) results) - (incf safe-top h))) - (incf left w))))) - -(defun make-image-tree (source-image geo-location &key - (output-images-size 256)) - "Constructs an image-tree with the given SOURCE-IMAGE. The root -IMAGE-TREE-NODE will be at GEO-LOCATION. All images will be scaled to -OUTPUT-IMAGES-SIZE." - (destructuring-bind (geo-x geo-y geo-width geo-height) geo-location - (let* ((source-image-width (cl-gd:image-width source-image)) - (source-image-height (cl-gd:image-height source-image)) - (scaler-x (/ source-image-width geo-width)) - (scaler-y (/ source-image-height geo-height)) - (classes '(image-tree . #1=(image-tree-node . #1#)))) - (labels ((image-point2geo-point (x y) - (list (+ (/ x scaler-x) geo-x) - (+ (/ y scaler-y) geo-y))) - (image-rect2geo-rect (rect) - (destructuring-bind (x y width height) - rect - (let ((x2 (+ x width)) - (y2 (+ y height))) - (destructuring-bind (geo-x geo-y) - (image-point2geo-point x y) - (destructuring-bind (geo-x2 geo-y2) - (image-point2geo-point x2 y2) - (list geo-x geo-y (- geo-x2 geo-x) (- geo-y2 geo-y))))))) - (image-small-enough (image-width image-height) - (and (<= image-width output-images-size) - (<= image-height output-images-size))) - (%make-image-tree (image-x image-y image-width image-height depth) - (let ((class (pop classes)) - (children (unless (image-small-enough image-width image-height) - (sort - (map-children-rects #'%make-image-tree - image-x image-y - (children-sizes image-width image-height) - (1+ depth)) - #'image-tree-node-less)))) - (cl-gd:with-image (image output-images-size output-images-size t) - (cl-gd:copy-image source-image image - image-x image-y 0 0 - image-width image-height - :resample t - :resize t - :dest-width output-images-size - :dest-height output-images-size) - #+nil - (cl-gd:with-default-color ((cl-gd:allocate-color 255 0 0 :image image)) - ;; (cl-gd:draw-string 10 10 (format nil "~D,~D (~D x ~D)" image-x image-y image-width image-height) - ;; :font :medium :image image) - (cl-gd:draw-rectangle (list 10 10 (- output-images-size 10) (- output-images-size 10)) - :image image)) - (make-image-tree-node image - :geo-rect (image-rect2geo-rect - (list image-x image-y image-width image-height)) - :children children - :class-name class - :depth depth))))) - (with-image-tree-node-counter - (%make-image-tree 0 0 source-image-width source-image-height 0)))))) - -(defun matrix-from-list (list &key (x-key #'first) (y-key #'second)) - "Converts a flat LIST to a matrix, by using X-KEY and Y-KEY to -associate a position to each element of LIST. " - (let* ((matrix (mapcar #'cdr (sort (group-on (sort (copy-list list) #'< :key x-key) :key y-key) #'< :key #'first))) - (width (length (first matrix)))) - (assert (every #'(lambda (row) (= width (length row))) matrix) - nil "Cant make a proper matrix from list, cause its rows wont have the same length.") - matrix)) - -(defun setp (list &key (test #'eql) (key #'identity)) - "Checks if LIST is a set (using TEST and KEY)." - (= (length list) - (length (remove-duplicates list :test test :key key)))) - -(defun every-eql-first-p (list &key (test #'eql) (key #'identity)) - "Checks if LIST only contains elements that are eql to its first -element using TEST and KEY)." - (let ((first-key (funcall key (first list)))) - (every #'(lambda (elt) (funcall test first-key (funcall key elt))) (cdr list)))) - -(deftransaction combine-image-trees (image-trees) - "Creates a new image-tree object that contains IMAGE-TREES as -children. All necessary adoptions for the new structure are -performed." - (labels ((reduce-min (&rest args) - (apply #'reduce #'min args)) - (reduce-max (&rest args) - (apply #'reduce #'max args)) - (normalize-depths (node &optional (depth 0)) - (setf (depth node) depth) - (mapc #'(lambda (child) (normalize-depths child (1+ depth))) (children node)) - node)) - (assert (setp image-trees :key #'(lambda (tree) (list (geo-x tree) (geo-y tree))) :test #'equal) - nil "The given image-trees have at least one duplicate with respect to their left-top position.") - (assert (every-eql-first-p image-trees :key #'(lambda (tree) (list (store-image-width tree) - (store-image-height tree))) - :test #'equal) - nil "The given image-trees must have the same width and height.") - (let* ((geo-x (reduce-min image-trees :key #'geo-x)) - (geo-y (reduce-min image-trees :key #'geo-y)) - (geo-x-max (reduce-max image-trees :key #'(lambda (tree) (+ (geo-x tree) (geo-width tree))))) - (geo-y-max (reduce-max image-trees :key #'(lambda (tree) (+ (geo-y tree) (geo-height tree))))) - (first-image-tree (first image-trees)) - (children-matrix (matrix-from-list image-trees :x-key #'geo-x :y-key #'geo-y)) - (children-matrix-width (length (first children-matrix))) - (children-matrix-height (length children-matrix))) - (cl-gd:with-image (image (store-image-width first-image-tree) - (store-image-height first-image-tree) - t) - ;; copy images - (flet ((scaler-x (x) (round (/ x children-matrix-width))) - (scaler-y (y) (round (/ y children-matrix-height)))) - (loop with dest-y = 0 - for row in children-matrix - do (loop with dest-x = 0 - for tree in row - do (with-store-image (source-image tree) - (cl-gd:copy-image source-image image - 0 0 (scaler-x dest-x) (scaler-y dest-y) - (store-image-width tree) (store-image-height tree) - :resample t - :resize t - :dest-width (scaler-x (store-image-width first-image-tree)) - :dest-height (scaler-y (store-image-height first-image-tree)))) - do (incf dest-x (store-image-width tree))) - do (incf dest-y (store-image-height (first row))))) - (normalize-depths - (with-image-tree-node-counter - (make-image-tree-node image :geo-rect (list geo-x geo-y (- geo-x-max geo-x) (- geo-y-max geo-y)) - :children (mapcar (alexandria:rcurry #'persistent-change-class 'image-tree-node) - image-trees) - :class-name 'image-tree))))))) - - -;; (cl-gd:with-image-from-file (image "/tmp/115606" :jpeg) -;; (make-image-tree image nil)) - -;; (cl-gd:with-image-from-file (image "/tmp/115606" :jpeg) -;; (make-image-tree image '(0 0 10 10))) - -(defclass image-tree-handler (object-handler) - () - (:default-initargs :object-class 'image-tree-node) - (:documentation "A simple html inspector for image-trees. Mainly - used for debugging.")) - - -(defun img-image-tree (object) - (html - ((:a :href (format nil "http://~a/image-tree/~d" (website-host) (store-object-id object))) - ((:img :src (format nil "http://~a/image/~d" (website-host) (store-object-id object))))))) - -(defmethod handle-object ((image-tree-handler image-tree-handler) (object image-tree-node)) - (with-bknr-page (:title (prin1-to-string object)) - #+nil(:pre - (:princ - (arnesi:escape-as-html - (with-output-to-string (*standard-output*) - (describe object))))) - (img-image-tree object) - (when (parent object) - (html - (:p - ((:a :href (format nil "http://~a/image-tree/~d" (website-host) (store-object-id (parent object)))) - "go to parent")))) - (:p "depth: " (:princ (depth object)) "lod-min:" (:princ (lod-min object)) "lod-max:" (:princ (lod-max object))) - (:table - (dolist (row (group-on (children object) :key #'geo-y :include-key nil)) - (html (:tr - (dolist (child row) - (html (:td (img-image-tree child)))))))))) - - -(defclass image-tree-kml-handler (object-handler) - () - (:default-initargs :object-class 'image-tree-node) - (:documentation "Generates a kml representation of the queried -image-tree-node. If the node has children, corresponding network -links are created.")) - -(defmethod handle-object ((handler image-tree-kml-handler) (obj image-tree-node)) - (hunchentoot:handle-if-modified-since (blob-timestamp obj)) - (with-xml-response (:content-type "text/xml; charset=utf-8" #+nil"application/vnd.google-earth.kml+xml" - :root-element "kml") - (setf (hunchentoot:header-out :last-modified) - (hunchentoot:rfc-1123-date (blob-timestamp obj))) - (let ((lod `(:min ,(lod-min obj) :max ,(lod-max obj))) - (rect (make-rectangle2 (list (geo-x obj) (geo-y obj) (geo-width obj) (geo-height obj))))) - (with-element "Document" - (kml-region rect lod) - (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id obj)) - rect - :draw-order (depth obj) - ;; :absolute 0 - ) - (dolist (child (children obj)) - (kml-network-link (format nil "http://~a/image-tree-kml/~d" (website-host) (store-object-id child)) - :rect (make-rectangle2 (list (geo-x child) (geo-y child) - (geo-width child) (geo-height child))) - :lod `(:min ,(lod-min child) :max ,(lod-max child)))))))) - -(defclass image-tree-kml-latest-handler (page-handler) - () - (:documentation "A convenience handler that redirects to the - IMAGE-TREE-KML-HANDLER of the latest created image-tree.")) - -(defmethod handle ((page-handler image-tree-kml-latest-handler)) - (redirect (format nil "http://~a/image-tree-kml/~d" (website-host) (store-object-id (car (last (class-instances 'image-tree))))))) - -;;;; -(defun image-tree-import-satellitenbild () - "A simple importer for our standard image." - (labels ((2x2-indices (left top) - `((,left ,top)(,(1+ left) ,top)(,left ,(1+ top))(,(1+ left) ,(1+ top)))) - (aref-indices (array indices) - (mapcar #'(lambda (index-pair) (destructuring-bind (x y) index-pair (aref array x y))) indices))) - (let ((array (make-array (list 4 4)))) - (loop with *default-pathname-defaults* = (merge-pathnames #p"tiles-2700/" (user-homedir-pathname)) - for name in '("sl_utm50s_01.png" - "sl_utm50s_02.png" - "sl_utm50s_03.png" - "sl_utm50s_04.png" - "sl_utm50s_05.png" - "sl_utm50s_06.png" - "sl_utm50s_07.png" - "sl_utm50s_08.png" - "sl_utm50s_09.png" - "sl_utm50s_10.png" - "sl_utm50s_11.png" - "sl_utm50s_12.png" - "sl_utm50s_13.png" - "sl_utm50s_14.png" - "sl_utm50s_15.png" - "sl_utm50s_16.png") - for i upfrom 0 - for x = (mod i 4) - for y = (floor i 4) - do (print (list 'importing x y)) - do (setf (aref array x y) - (cl-gd:with-image-from-file (image (merge-pathnames name)) - (make-image-tree image (list (* (mod i 4) 2700) (* (floor i 4) 2700) - 2700 2700))))) - (combine-image-trees - (list (combine-image-trees (aref-indices array (2x2-indices 0 0))) - (combine-image-trees (aref-indices array (2x2-indices 0 2))) - (combine-image-trees (aref-indices array (2x2-indices 2 0))) - (combine-image-trees (aref-indices array (2x2-indices 2 2)))))))) Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-17 14:48:01 UTC (rev 3491) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-17 15:17:01 UTC (rev 3492) @@ -52,9 +52,6 @@ (when (sponsor-info-text sponsor) (text (sponsor-info-text sponsor)))))))) -(defun image-tree-root-id () - (store-object-id (first (class-instances 'image-tree)))) - (defclass kml-root-handler (object-handler) ((timestamp :accessor timestamp :initform (get-universal-time)))) @@ -85,14 +82,7 @@ (with-element "altitude" (text "0")) (with-element "range" (text "1134.262777389377")) (with-element "tilt" (text "0")) - (with-element "heading" (text "1.391362238653075"))) - (let ((image-tree (find-store-object (image-tree-root-id)))) - (assert (and image-tree (typep image-tree 'image-tree)) nil - "(find-store-object (image-tree-root-id)) gives ~s" image-tree) - (kml-network-link (format nil "http://~a/image-tree-kml/~d" (website-host) (image-tree-root-id)) - :rect (make-rectangle2 (geo-location image-tree)) - :lod `(:min ,(lod-min image-tree) :max ,(lod-max image-tree)) - :name "old-image-tree")) + (with-element "heading" (text "1.391362238653075"))) (dolist (sat-layer (class-instances 'sat-layer)) (kml-network-link (format nil "http://~a/sat-root-kml?name=~A" (website-host) (name sat-layer)) :rect (geo-box-rectangle *m2-geo-box*) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-17 14:48:01 UTC (rev 3491) +++ trunk/projects/bos/web/webserver.lisp 2008-07-17 15:17:01 UTC (rev 3492) @@ -199,10 +199,7 @@ :handler-definitions `(("/edit-poi" edit-poi-handler) ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) - ("/kml-root" kml-root-handler) - ("/image-tree-kml-latest" image-tree-kml-latest-handler) - ("/image-tree-kml" image-tree-kml-handler) - ("/image-tree" image-tree-handler) + ("/kml-root" kml-root-handler) ("/country-stats" country-stats-handler) ("/contract-tree-kml" contract-tree-kml-handler) ("/contract-tree-image" contract-tree-image-handler)

1 0

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

17 Jul '08

Revision: 3491 Author: hans URL: http://bknr.net/trac/changeset/3491 Add option to ignore objects in a snapshot that are of now-nonexistant classes. 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-17 14:11:47 UTC (rev 3490) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-17 14:48:01 UTC (rev 3491) @@ -353,15 +353,15 @@ (%encode-integer (store-object-id object) stream) (%encode-set-slots slots object stream))) -(defvar *class-rename-hash*) - (defun find-class-with-interactive-renaming (class-name) - (loop until (find-class class-name nil) + (loop until (or (null class-name) + (find-class class-name nil)) do (progn - (format *query-io* "Class ~A not found, enter new class: " class-name) + (format *query-io* "Class ~A not found, enter new class or enter NIL to ignore objects of this class: " class-name) (finish-output *query-io*) (setq class-name (read *query-io*)))) - (setf (gethash class-name *class-rename-hash*) (find-class class-name))) + (and class-name + (find-class class-name))) (defun find-slot-name-with-interactive-rename (class slot-name) (loop until (find slot-name (class-slots class) :key #'slot-definition-name) @@ -406,20 +406,24 @@ (class-name (%decode-symbol stream)) (nslots (%decode-integer stream)) (class (find-class-with-interactive-renaming class-name)) - (slots (find-class-slots-with-interactive-renaming class (loop - repeat nslots - collect (%decode-symbol stream))))) + (slot-names (loop repeat nslots collect (%decode-symbol stream))) + (slots (if class + (find-class-slots-with-interactive-renaming class slot-names) + slot-names))) (setf (gethash id layouts) (cons class slots)))) (defun %read-slots (stream object slots) + "Read the OBJECT from STREAM. The individual slots of the object +are expected in the order of the list SLOTS. If the OBJECT is NIL, +the slots are read from the snapshot and ignored." (declare (optimize (speed 3))) (dolist (slot-name slots) - (if slot-name ; NIL for slots which are not restored because of schema changes + (if slot-name ; NIL for slots which are not restored because of schema changes (restart-case (let ((*current-object-slot* (list object slot-name)) - (*current-slot-relaxed-p* - (store-object-relaxed-object-reference-p object slot-name))) + (*current-slot-relaxed-p* (or (null object) + (store-object-relaxed-object-reference-p object slot-name)))) (let ((value (decode stream))) (when object (let ((bknr.indices::*indices-remove-p* nil)) @@ -437,30 +441,25 @@ (defun snapshot-read-object (stream layouts) (declare (optimize (speed 3))) (with-simple-restart (skip-object "Skip the object.") - (let ((layout-id (%decode-integer stream)) - (object-id (%decode-integer stream))) - #+nil (format t "id: ~A~%" object-id) - (destructuring-bind (class &rest slots) (gethash layout-id layouts) - (declare (ignore slots)) - #+nil (format t "; class: ~A~%" class) - (let ((result (make-instance class :id object-id))) - result))))) + (let* ((layout-id (%decode-integer stream)) + (object-id (%decode-integer stream)) + (class (first (gethash layout-id layouts)))) + ;; If the class is NIL, it was not found in the currently + ;; running Lisp image and objects of this class will be ignored. + (when class + (make-instance class :id object-id))))) (defun snapshot-read-slots (stream layouts) (let* ((layout-id (%decode-integer stream)) (object-id (%decode-integer stream)) (object (store-object-with-id object-id))) (restart-case - (progn - #+nil (format t "read-slots for object ~A, id ~A~%" object object-id) - (unless object - (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id)) - (%read-slots stream object (cdr (gethash layout-id layouts)))) - (skip-object-initialization () - :report "Skip object initialization.") - (delete-object () - :report "Delete the object." - (delete-object object))))) + (%read-slots stream object (cdr (gethash layout-id layouts))) + (skip-object-initialization () + :report "Skip object initialization.") + (delete-object () + :report "Delete the object." + (delete-object object))))) (defmethod encode-object ((object store-object) stream) (if (object-destroyed-p object) @@ -563,7 +562,6 @@ (created-objects 0) (read-slots 0) (error t) - (*class-rename-hash* (make-hash-table)) (*slot-name-map* nil)) (unwind-protect (progn @@ -584,8 +582,8 @@ (format t "unknown char ~A at offset ~A~%" char (file-position s))) (ecase char ((nil) (return)) - (#\O (snapshot-read-object s class-layouts) (incf created-objects)) (#\L (snapshot-read-layout s class-layouts)) + (#\O (snapshot-read-object s class-layouts) (incf created-objects)) (#\S (snapshot-read-slots s class-layouts) (incf read-slots)))))) (map-store-objects #'initialize-transient-instance) (setf error nil))

1 0

[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

← Newer
1
...
20
21
22
23
24
25
26
...
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008