Changeset 3437
- Timestamp:
- 07/14/08 20:10:10 (6 months ago)
- Files:
-
- trunk/projects/bos/web/contract-tree.lisp (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
trunk/projects/bos/web/contract-tree.lisp
r3433 r3437 4 4 (defclass contract-node (node-extension) 5 5 ((name :allocation :class :initform 'contract-node) 6 (timestamp :accessor timestamp :initform (get-universal-time))6 (timestamp :accessor timestamp) 7 7 (placemark-contracts :initform nil :accessor placemark-contracts) 8 8 (image :initform nil :accessor image) 9 9 (kml-req-count :initform 0 :accessor kml-req-count) 10 10 (image-req-count :initform 0 :accessor image-req-count))) 11 12 (defun contract-node-find-corresponding-store-image (node) 13 (first (get-keyword-store-images (contract-node-keyword node)))) 14 15 (defmethod initialize-instance :after ((node contract-node) &key args) 16 (declare (ignore args)) 17 (let ((image (contract-node-find-corresponding-store-image node))) 18 (if (and image (probe-file (blob-pathname image))) 19 (setf (image node) image 20 (timestamp node) (blob-timestamp image)) 21 (setf (timestamp node) (get-universal-time))))) 11 22 12 23 (defvar *contract-tree* nil) … … 200 211 ;; contract-node points to the current store-image. 201 212 202 (defun contract-node-store-image-name (node) 203 (format nil "contract-node~{~D~}" (node-path node))) 213 (defun contract-node-keyword (node) 214 "Used to relate NODE to its store-image." 215 (intern (format nil "CONTRACT-NODE~{~D~}" (node-path node)) #.(find-package "KEYWORD"))) 216 217 (defun contract-node-store-image-name (node old-store-image) 218 "Used only as a placeholder for store-image-name that always 219 has to be unique." 220 (let ((next-internal-id (if old-store-image 221 (store-object-id old-store-image) 222 0))) 223 (format nil "contract-node~{~d~}_~D" (node-path node) next-internal-id))) 204 224 205 225 (defun contract-node-update-image (node) … … 227 247 (find-contract-color contract) 228 248 transparent)))))))) 229 (let* ((image-name (contract-node-store-image-name node)) 230 (old-store-image (store-image-with-name image-name))) 231 (when old-store-image (delete-object old-store-image)) 232 (setf (image node) 233 (make-store-image :name image-name 234 :type :png))))))) 249 (let* ((keyword (contract-node-keyword node)) 250 (old-store-image (contract-node-find-corresponding-store-image node)) 251 (new-store-image (make-store-image :name (contract-node-store-image-name node old-store-image) 252 :type :png 253 :keywords (list keyword)))) 254 ;; activate new-store-image 255 (setf (image node) new-store-image) 256 ;; delete the old one 257 (when old-store-image 258 (delete-file (blob-pathname old-store-image)) 259 (delete-object old-store-image))))))) 235 260 236 261 (defun contract-node-update-image-if-needed (node) 237 262 (when (or (null (image node)) 263 (not (probe-file (blob-pathname (image node)))) 238 264 (> (timestamp node) (blob-timestamp (image node)))) 239 265 (contract-node-update-image node))) … … 264 290 (when (contract-published-p contract) 265 291 (insert-contract *contract-tree* contract))) 266 (format t "~&rendering contract-tree images ...")292 (format t "~&rendering contract-tree images if needed...") 267 293 (map-nodes #'contract-node-update-image-if-needed *contract-tree*) 268 (format t "done.~%") 269 (bknr.datastore::delete-orphaned-blob-files nil) 294 (format t "done.~%") 270 295 (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* 271 296 (list 0 0 +width+ +width+)
