Revision: 3437 Author: ksprotte URL: http://bknr.net/trac/changeset/3437

improved the way contract-tree uses store-images for caching U trunk/projects/bos/web/contract-tree.lisp

Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-14 14:33:26 UTC (rev 3436) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-14 18:10:10 UTC (rev 3437) @@ -3,12 +3,23 @@ ;;; contract-node (defclass contract-node (node-extension) ((name :allocation :class :initform 'contract-node) - (timestamp :accessor timestamp :initform (get-universal-time)) + (timestamp :accessor timestamp) (placemark-contracts :initform nil :accessor placemark-contracts) (image :initform nil :accessor image) (kml-req-count :initform 0 :accessor kml-req-count) (image-req-count :initform 0 :accessor image-req-count)))

+(defun contract-node-find-corresponding-store-image (node) + (first (get-keyword-store-images (contract-node-keyword node)))) + +(defmethod initialize-instance :after ((node contract-node) &key args) + (declare (ignore args)) + (let ((image (contract-node-find-corresponding-store-image node))) + (if (and image (probe-file (blob-pathname image))) + (setf (image node) image + (timestamp node) (blob-timestamp image)) + (setf (timestamp node) (get-universal-time))))) + (defvar *contract-tree* nil) (defparameter *contract-tree-images-size* 128) ; was 256

@@ -199,9 +210,18 @@ ;; contract-images are stored as store-images. The image slot of ;; contract-node points to the current store-image.

-(defun contract-node-store-image-name (node) - (format nil "contract-node~{~D~}" (node-path node))) +(defun contract-node-keyword (node) + "Used to relate NODE to its store-image." + (intern (format nil "CONTRACT-NODE~{~D~}" (node-path node)) #.(find-package "KEYWORD")))

+(defun contract-node-store-image-name (node old-store-image) + "Used only as a placeholder for store-image-name that always +has to be unique." + (let ((next-internal-id (if old-store-image + (store-object-id old-store-image) + 0))) + (format nil "contract-node~{~d~}_~D" (node-path node) next-internal-id))) + (defun contract-node-update-image (node) (labels ((find-contract-color (contract) (destructuring-bind (r g b) @@ -226,15 +246,21 @@ (if (and contract (contract-paidp contract)) (find-contract-color contract) transparent)))))))) - (let* ((image-name (contract-node-store-image-name node)) - (old-store-image (store-image-with-name image-name))) - (when old-store-image (delete-object old-store-image)) - (setf (image node) - (make-store-image :name image-name - :type :png))))))) + (let* ((keyword (contract-node-keyword node)) + (old-store-image (contract-node-find-corresponding-store-image node)) + (new-store-image (make-store-image :name (contract-node-store-image-name node old-store-image) + :type :png + :keywords (list keyword)))) + ;; activate new-store-image + (setf (image node) new-store-image) + ;; delete the old one + (when old-store-image + (delete-file (blob-pathname old-store-image)) + (delete-object old-store-image)))))))

(defun contract-node-update-image-if-needed (node) (when (or (null (image node)) + (not (probe-file (blob-pathname (image node)))) (> (timestamp node) (blob-timestamp (image node)))) (contract-node-update-image node)))

@@ -263,10 +289,9 @@ (dolist (contract (class-instances 'contract)) (when (contract-published-p contract) (insert-contract *contract-tree* contract))) - (format t "~&rendering contract-tree images...") + (format t "~&rendering contract-tree images if needed...") (map-nodes #'contract-node-update-image-if-needed *contract-tree*) - (format t "done.~%") - (bknr.datastore::delete-orphaned-blob-files nil) + (format t "done.~%") (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* (list 0 0 +width+ +width+) #'contract-tree-changed))