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

[bknr-cvs] hans changed trunk/
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3683 Author: hans URL: http://bknr.net/trac/changeset/3683 Checkpoint Quickhoney. Added archive to RSS feed class. U trunk/bknr/modules/text/blog.lisp U trunk/bknr/web/src/packages.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/image.lisp U trunk/projects/quickhoney/src/packages.lisp A trunk/projects/quickhoney/src/twitter.lisp U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/bknr/modules/text/blog.lisp =================================================================== --- trunk/bknr/modules/text/blog.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/bknr/modules/text/blog.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -16,7 +16,7 @@ (articles :update :initform nil) (owners :update :initform nil))) -(defmethod rss-channel-items ((blog blog)) +(defmethod rss-channel-items ((blog blog) &key) (blog-articles blog)) (defmethod print-object ((object blog) stream) Modified: trunk/bknr/web/src/packages.lisp =================================================================== --- trunk/bknr/web/src/packages.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/bknr/web/src/packages.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -33,6 +33,8 @@ #:rss-channel-image #:rss-channel-textinput #:rss-channel-items + #:rss-channel-archive + #:rss-channel-archived-months #:rss-channel-xml ;; item Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -21,8 +21,10 @@ (path :update :initform nil) (description :update :initform nil) (last-update :update :initform (get-universal-time)) - (max-item-age :update :initform (* 4 7 24 60 60)) - (items :update :initform nil)) + (max-item-age :update + :initform 28 + :documentation "default maximum item age in days") + (items :none :initform nil)) (:documentation "RSS-CHANNEL models one rss channel. Items are added to a channel by deriving other persistent classes from the mixin class RSS-ITEM. When an object of such a derived class is created, it @@ -60,7 +62,8 @@ (defmethod prepare-for-snapshot ((channel rss-channel)) "When snapshotting, remove items from CHANNEL that are destroyed." - (setf (slot-value channel 'items) (remove-if #'object-destroyed-p (rss-channel-items channel)))) + (setf (slot-value channel 'items) + (remove-if #'object-destroyed-p (rss-channel-items channel)))) ;; Mixin for items @@ -108,16 +111,42 @@ (rss-channel-items channel))) (rss-item-xml item))))))) -(defgeneric rss-channel-items (channel) +(defun days-from-query-parameter () + (when (boundp 'hunchentoot:*request*) + (let ((days-string (bknr.web:query-param "days"))) + (when days-string + (parse-integer days-string))))) + +(defun rss-channel-archive (channel) + "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" + (group-on (rss-channel-items channel) + :test #'equal + :key (lambda (item) + (multiple-value-bind (seconds minutes hours day month year) + (decode-universal-time (rss-item-pub-date item)) + (declare (ignore seconds minutes hours day)) + (list month year))))) + +(defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (:method ((channel rss-channel)) - (let ((days (when (boundp 'hunchentoot:*request*) (bknr.web:query-param "days")))) - (let ((expiry-time (- (get-universal-time) (if days - (* 60 60 25 (parse-integer days)) - (rss-channel-max-item-age channel))))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items)))))) + (:method ((channel rss-channel) &key days month) + (cond + (month + (cdr (find month (rss-channel-archive channel) :test #'equal))) + (t + (let* ((days (or days + (days-from-query-parameter) + (rss-channel-max-item-age channel))) + (expiry-time (- (get-universal-time) (* 60 60 25 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items))))))) + +(defgeneric rss-channel-archived-months (channel) + (:documentation "Return a list of lists (MONTH YEAR) for which the + CHANNEL has archived entries.") + (:method (channel) + (mapcar #'car (rss-channel-archive channel)))) (deftransaction rss-channel-cleanup (channel) "Remove expired items from the items list. Can be used to reduce Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/src/image.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -100,7 +100,7 @@ () (:metaclass persistent-class)) -(defmethod rss-channel-items ((channel quickhoney-rss-channel)) +(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key) (remove-if (lambda (item) (and (typep item 'quickhoney-image) (quickhoney-image-explicit item))) Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/src/packages.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -63,4 +63,8 @@ #:response-error)) (defpackage :paypal-test - (:use :cl)) \ No newline at end of file + (:use :cl)) + +(defpackage :twitter + (:use :cl) + (:export #:update-status)) \ No newline at end of file Added: trunk/projects/quickhoney/src/twitter.lisp =================================================================== --- trunk/projects/quickhoney/src/twitter.lisp (rev 0) +++ trunk/projects/quickhoney/src/twitter.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -0,0 +1,12 @@ +(in-package :twitter) + +(defparameter *authorization* '("QuickHoneyTest" "autotwitter") + "Authorization (USER PASSWORD) to use to identify to twitter") + +(defun update-status (status-string) + (babel:octets-to-string + (drakma:http-request "http://twitter.com/statuses/update.xml" + :method :post + :content (format nil "status=~A" status-string) + :content-type "application/x-www-form-urlencoded" + :basic-authorization *authorization*))) \ No newline at end of file Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-29 22:25:41 UTC (rev 3683) @@ -23,10 +23,6 @@ /* current colors */ -var foreground_color = '000000'; -var background_color = 'ffffff'; -var link_color; - /* ie 5 / mac compatibility routine */ function push(array, item) { @@ -215,49 +211,15 @@ this.products.push(product); $('checkout').style.visibility = 'visible'; } -} +}; /* news */ -function loadXMLDoc(fname) +function load_news() { - var xmlDoc; - - // code for IE - if (window.ActiveXObject) { - xmlDoc = new ActiveXObject("Microsoft.XMLDOM"); - } - else if (document.implementation - && document.implementation.createDocument) { - // code for Mozilla, Firefox, Opera, etc. - xmlDoc = document.implementation.createDocument("","",null); - } else { - alert('Your browser cannot handle this script'); - } - xmlDoc.async = false; - xmlDoc.load(fname); - - return xmlDoc; + } -function xstlTransformDocumentToElement(document, stylesheet, elementId) -{ - xml = loadXMLDoc(document); - xsl = loadXMLDoc(stylesheet); - if (window.ActiveXObject) { - // code for IE - ex = xml.transformNode(xsl); - document.getElementById(elementId).innerHTML = ex; - } else if (document.implementation - && document.implementation.createDocument) { - // code for Mozilla, Firefox, Opera, etc. - xsltProcessor = new XSLTProcessor(); - xsltProcessor.importStylesheet(xsl); - resultDocument = xsltProcessor.transformToFragment(xml,document); - document.getElementById(elementId).appendChild(resultDocument); - } -} - /* image database */ var current_directory; @@ -386,15 +348,15 @@ var pages = []; -function Page(elements, colors, action) { +function Page(elements, link_color, action) { this.elements = elements; - this.colors = colors; + this.link_color = link_color; this.action = action; } pages['home'] = new Page(['home_page'], - ['000000', 'ffffff', '953cfd'], + '953cfd', function() { footer_down(); @@ -410,7 +372,7 @@ pages['pixel'] = new Page(['directory_page'], - ['000000', 'ffffff', 'ff00ff'], + 'ff00ff', function() { footer_up(); directory('pixel'); @@ -418,7 +380,7 @@ pages['vector'] = new Page(['directory_page'], - ['000000', 'ffffff', '00ccff'], + '00ccff', function() { footer_up(); directory('vector'); @@ -426,21 +388,22 @@ pages['news'] = new Page(['news_page'], - ['000000', 'ffffff', '30be01'], + '30be01', function() { footer_hide(); + load_news(); }); pages['shop'] = new Page(['results'], - ['000000', 'ffffff', '0054ff'], + '0054ff', function() { footer_hide(); }); pages['cart'] = new Page(['cart_page'], - ['000000', 'ffffff', '0054ff'], + '0054ff', function() { show_shopping_cart(); footer_hide(); @@ -448,7 +411,7 @@ pages['contact'] = new Page(['contact_page'], - ['000000', 'ffffff', 'ffa200'], + 'ffa200', function() { footer_hide(); @@ -459,17 +422,6 @@ current_directory = 'contact'; }); -function change_colors(pagename, colors) { - - foreground_color = colors[0]; - background_color = colors[1]; - link_color = colors[2]; - - // change text colors - $("body").style.backgroundColor = "#" + background_color; - $("body").style.color = "#" + foreground_color; -} - function display_cms_window() { if (logged_in) { @@ -504,7 +456,6 @@ debug('show_page ' + pagename); // Activate the menu by coloring the buttons correctly - change_colors(pagename, page.colors); $('menu').className = pagename; document.body.className = pagename; @@ -820,7 +771,7 @@ + current_directory + '/' + current_subdirectory + '/' + image.name + '" onclick="display_image(' + "'" + image.position + "'" + ');">' + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + '" ' - + ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + ',8" ' + + ' src="/image/' + image.name + '/cell,ffffff,' + cell_width + ',' + cell_height + ',8" ' + ' onload="reveal_image(this);" />' + '</a>'; } @@ -1143,7 +1094,7 @@ overlay.className = current_directory; replaceChildNodes(overlay, H1(null, title), - IMG({ src: '/image/overlay-close/color,000000,' + pages[current_directory].colors[2], + IMG({ src: '/image/overlay-close/color,000000,' + pages[current_directory].link_color, id: 'close', width: 13, height: 13})); overlay.style.width = width + 'px'; $('close').style.left = (width - 23) + 'px'; @@ -1318,7 +1269,7 @@ function recolored_image_path(name) { - return '/image/' + name + '/color,ff00ff,' + pages[current_directory].colors[2]; + return '/image/' + name + '/color,ff00ff,' + pages[current_directory].link_color; } function make_image_action_button(name, action, height) Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-29 22:25:41 UTC (rev 3683) @@ -109,6 +109,8 @@ #menu.contact a#m_contact img.selected { visibility: visible } #menu.contact a#m_contact img.unselected { visibility: hidden } +.autonews a { color: #30be01; } + #menu img.selected { visibility: hidden; z-index: 110; @@ -431,16 +433,18 @@ width: 428px; height: 108px; position: relative; - } +} .newsentry img { position: absolute; top: 5px; left: 5px; - } +} + .newsentry div { position: absolute; top: 5px; left: 118px; - } +} + .newsentry h1 { margin: 0px 0px 2px 0px; font-size: 120%; @@ -450,8 +454,7 @@ .news_vector { background-color: #00ccff; } .news_pixel { background-color: #ff00ff; } -.news_pixel a { background-color: #ff00ff; } - +.autonews a { color: white } div.news_sep { width: 428px; height: 17px; background-image: url(/image/news-sep); } /* cms styles */ Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-29 22:25:41 UTC (rev 3683) @@ -131,7 +131,7 @@ <div id="news_page"> <p id="news_content"> - <div class="newsentry news_vector"> + <div class="newsentry news_vector autonews"> <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> <div> <h1>Jan and Ella</h1> @@ -141,7 +141,7 @@ </div> <div class="news_sep"> </div> <br/> - <div class="newsentry news_pixel"> + <div class="newsentry news_pixel autonews"> <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> <div> March 8th, 2008 by Peter | <a href="foo">permalink</a><br/>

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3682 Author: hans URL: http://bknr.net/trac/changeset/3682 Fix anonymous transactions: Instead of storing the subtransactions and then serializing them at the end of the transaction, they are now serialized immediately to an in-memory buffer and written to the transaction log at the end of the transaction in one fell swoop. Add condition classes for most errors that are signaled from txn.lisp U trunk/bknr/datastore/src/data/object-tests.lisp U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/txn.lisp Modified: trunk/bknr/datastore/src/data/object-tests.lisp =================================================================== --- trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -45,22 +45,25 @@ (call-next-method) (close-store))) +(defvar *tests* (make-hash-table)) + (defmacro define-datastore-test (name &rest body) - `(make-instance 'datastore-test-class - :unit :datastore - :name ,name - :body (lambda () - ,@body))) + `(setf (gethash ,name *tests*) + (make-instance 'datastore-test-class + :unit :datastore + :name ,name + :body (lambda () + ,@body)))) -(define-datastore-test "Datastore setup" +(define-datastore-test :store-setup (test-assert *test-datastore*)) -(define-datastore-test "Create object" +(define-datastore-test :create-object (let ((obj (make-object 'store-object))) (test-assert obj) (test-equal (list obj) (all-store-objects)))) -(define-datastore-test "Create multiple objects" +(define-datastore-test :create-multiple-objects (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -68,7 +71,7 @@ (test-equal (length (all-store-objects)) 2) (test-assert (subsetp (list o1 o2) (all-store-objects))))) -(define-datastore-test "Delete multiple objects" +(define-datastore-test :delete-multiple-objects (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -80,23 +83,23 @@ (delete-object o2) (test-equal (all-store-objects) nil))) -(define-datastore-test "Restore" +(define-datastore-test :restore (make-object 'store-object) (restore) (test-equal (length (all-store-objects)) 1)) -(define-datastore-test "Snapshot and Restore" +(define-datastore-test :snapshot-and-restore (make-object 'store-object) (snapshot) (restore) (test-equal (length (all-store-objects)) 1)) -(define-datastore-test "Restore multiple objects" +(define-datastore-test :restore-multiple-objects (dotimes (i 10) (make-object 'store-object)) (restore) (test-equal (length (all-store-objects)) 10)) -(define-datastore-test "Snapshot and Restore multiple objects" +(define-datastore-test :snapshot-restore-multiple-objects (dotimes (i 10) (make-object 'store-object)) (snapshot) (restore) @@ -104,7 +107,7 @@ (defconstant +stress-size+ 10000) -(define-datastore-test "Stress test object creation" +(define-datastore-test :stress-test (format t "Creating ~a objects~%" +stress-size+) (time (bknr.datastore::without-sync () (dotimes (i +stress-size+) @@ -121,10 +124,19 @@ (define-persistent-class child () ()) -(define-datastore-test "Serialize circular dependency in anonymous txn" +(define-datastore-test :serialize-circular-in-anon-txn (let ((parent (make-object 'parent))) (with-transaction (:circular) (setf (parent-child parent) (make-object 'child)))) (restore) (test-equal (find-class 'child) - (class-of (parent-child (first (class-instances 'parent)))))) \ No newline at end of file + (class-of (parent-child (first (class-instances 'parent)))))) + +(define-datastore-test :delete-object-in-anon-txn + (let (object) + (with-transaction (:make) + (setf object (make-object 'child))) + (with-transaction (:delete) + (delete-object object)) + (restore) + (test-assert (object-destroyed-p object)))) \ No newline at end of file Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -96,11 +96,11 @@ (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) - (push (make-instance 'transaction - :timestamp (get-universal-time) - :function-symbol 'tx-change-slot-values - :args (list object (slot-definition-name slotd) newval)) - (anonymous-transaction-transactions *current-transaction*)))) + (encode (make-instance 'transaction + :timestamp (get-universal-time) + :function-symbol 'tx-change-slot-values + :args (list object (slot-definition-name slotd) newval)) + (anonymous-transaction-log-buffer *current-transaction*)))) (defmethod direct-slot-definition-class ((class persistent-class) &key &allow-other-keys) 'persistent-direct-slot-definition) @@ -195,17 +195,17 @@ (if (in-anonymous-transaction-p) (prog1 (call-next-method) - (push (make-instance 'transaction - :function-symbol 'make-instance - :timestamp (get-universal-time) - :args (cons (class-name (class-of object)) - (loop for slotd in (class-slots (class-of object)) - for slot-name = (slot-definition-name slotd) - for slot-initarg = (first (slot-definition-initargs slotd)) - when (and slot-initarg - (slot-boundp object slot-name)) - appending (list slot-initarg (slot-value object slot-name))))) - (anonymous-transaction-transactions *current-transaction*))) + (encode (make-instance 'transaction + :function-symbol 'make-instance + :timestamp (get-universal-time) + :args (cons (class-name (class-of object)) + (loop for slotd in (class-slots (class-of object)) + for slot-name = (slot-definition-name slotd) + for slot-initarg = (first (slot-definition-initargs slotd)) + when (and slot-initarg + (slot-boundp object slot-name)) + appending (list slot-initarg (slot-value object slot-name))))) + (anonymous-transaction-log-buffer *current-transaction*))) (call-next-method))) (defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) @@ -661,7 +661,8 @@ (destroy-object (store-object-with-id id))) (defun delete-object (object) - (if (in-transaction-p) + (if (and (in-transaction-p) + (not (in-anonymous-transaction-p))) (destroy-object object) (execute (make-instance 'transaction :function-symbol 'tx-delete-object :timestamp (get-universal-time) Modified: trunk/bknr/datastore/src/data/txn.lisp =================================================================== --- trunk/bknr/datastore/src/data/txn.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/txn.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -10,13 +10,67 @@ (define-condition not-in-transaction (error) () (:documentation - "Thrown when an operation on persistent slots is executed outside a transaction context")) + "Signaled when an operation on persistent slots is executed outside + a transaction context")) (define-condition store-not-open (error) () (:documentation - "Thrown when a transaction is executed on a store that is not opened")) + "Signaled when a transaction is executed on a store that is not + opened")) +(define-condition store-already-open (error) + () + (:documentation + "Signaled when an attempt is made to open a store with another + store being open")) + +(define-condition invalid-store-random-state (error) + () + (:documentation + "Signaled when the on-disk store random state cannot be read, + typically because it has been written with another Lisp")) + +(define-condition unsupported-lambda-list-option (error) + ((option :initarg :option :reader option)) + (:documentation + "Signaled when DEFTRANSACTION is used with an unsupported option in + its lambda list")) + +(define-condition default-arguments-unsupported (error) + ((tx-name :initarg :tx-name :reader tx-name) + (argument :initarg :argument :reader argument)) + (:report (lambda (c stream) + (format stream "argument ~A defaulted in DEFTRANSACTION ~S" + (argument c) (tx-name c)))) + (:documentation + "Signaled when an argument in a DEFTRANSACTION definition has a + default declaration")) + +(define-condition undefined-transaction (error) + ((tx-name :initarg :tx-name :reader tx-name)) + (:report (lambda (c stream) + (format stream "undefined transaction ~A in transaction log, please ensure that all the necessary code is loaded." + (tx-name c)))) + (:documentation + "Signaled when a named transaction is loaded from the transaction + log and no matching function definition could be found")) + +(define-condition invalid-transaction-nesting (error) + () + (:documentation + "Signaled when WITH-TRANSACTION forms are nested.")) + +(define-condition anonymous-transaction-in-named-transaction (error) + () + (:documentation + "Signaled when an anonymous transaction is started from within a named transaction.")) + +(define-condition no-subsystems (error) + () + (:documentation + "Signaled when an attempt is made to snapshot a store without subsystems")) + ;;; store (defvar *store*) @@ -74,7 +128,7 @@ (restart-case (when (and (boundp '*store*) *store*) - (error "A store is already opened.")) + (error 'store-already-open)) (close-store () :report "Close the opened store." (close-store))))) @@ -153,7 +207,7 @@ (read f) (error (e) (declare (ignore e)) - (error "Invalid store random state")))) + (error 'invalid-store-random-state)))) (initialize-store-random-state () :report "Initialize the random state of the store. Use this to reinitialize the random state of the store when porting over a @@ -245,7 +299,7 @@ (defun store-current-transaction () (if (in-transaction-p) *current-transaction* - (error "store-current-transaction called outside of a transaction"))) + (error 'not-in-transaction))) ;;; All transactions are executed by an 'executor', which is the store ;;; itself or, in the case of a nested transaction, the parent @@ -262,7 +316,7 @@ (defmethod execute-transaction :before (executor transaction) (unless (store-open-p) - (error (make-condition 'store-not-open)))) + (error 'store-not-open))) (defmethod execute-transaction ((executor transaction) transaction) (execute-unlogged transaction)) @@ -317,7 +371,7 @@ (&optional) (&rest (setf args (cdr args))) ; skip argument, too (&key (setf in-keywords-p t)) - (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) + (otherwise (error 'unsupported-lambda-list-option :option arg)))) (t (when in-keywords-p (push (intern (symbol-name arg) :keyword) result)) @@ -335,7 +389,7 @@ (body body)) (dolist (arg args) (when (listp arg) - (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) + (error 'default-arguments-unsupported :tx-name name :argument (car arg)))) (let ((tx-name (intern (format nil "TX-~A" name) (symbol-package name)))) `(progn @@ -408,8 +462,8 @@ (with-store-guard () (let ((*current-transaction* transaction)) (apply (or (symbol-function (transaction-function-symbol transaction)) - (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded." - (transaction-function-symbol transaction))) + (error 'undefined-transaction + :tx-name (transaction-function-symbol transaction))) (transaction-args transaction))))) (defun fsync (stream) @@ -436,7 +490,7 @@ (check-type transaction symbol) ; otherwise care for multiple evaluation `(with-store-guard () (when (in-transaction-p) - (error "can't open nested with-transaction-log blocks")) + (error 'invalid-transaction-nesting)) (with-store-state (:transaction) (prog1 (let ((*current-transaction* ,transaction)) @@ -472,61 +526,54 @@ ;;; The actual writing to the transaction log is performed by the ;;; with-transaction macro. -;;; An anonymous transaction has an optional label which is stored in -;;; the transaction log in order to make the source code location where +;;; An anonymous transaction has a label which is stored in the +;;; transaction log in order to make the source code location where ;;; the actual transaction code lives identifieable. (defclass anonymous-transaction (transaction) - ((label :initarg :label :accessor anonymous-transaction-label) - (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) - (:default-initargs :transactions nil :label nil)) + ((label :initarg :label + :accessor anonymous-transaction-label + :initform (error "missing label in anonymous transaction definition")) + (log-buffer :initarg :log-buffer + :accessor anonymous-transaction-log-buffer + :initform (flex:make-in-memory-output-stream)))) (defmethod print-object ((transaction anonymous-transaction) stream) (print-unreadable-object (transaction stream :type t) - (format stream "~A ~A ~A" + (format stream "~A ~A (~A)" (format-date-time (transaction-timestamp transaction)) (anonymous-transaction-label transaction) - (anonymous-transaction-transactions transaction)))) + (class-name (class-of (anonymous-transaction-log-buffer transaction)))))) (defmethod in-anonymous-transaction-p () (subtypep (type-of *current-transaction*) 'anonymous-transaction)) (defmethod encode-object ((transaction anonymous-transaction) stream) - (cond - ((anonymous-transaction-label transaction) - (%write-tag #\N stream) - (%encode-string (anonymous-transaction-label transaction) stream)) - (t - (%write-tag #\G stream))) - (%encode-list (reverse (anonymous-transaction-transactions transaction)) stream)) + (%write-tag #\N stream) + (%encode-string (anonymous-transaction-label transaction) stream) + (let ((subtxns (flex:get-output-stream-sequence (anonymous-transaction-log-buffer transaction)))) + (%encode-integer (length subtxns) stream) + (write-sequence subtxns stream))) -(defmethod decode-object ((tag (eql #\G)) stream) - (make-instance 'anonymous-transaction - :transactions (%decode-list stream))) - (defvar *txn-log-stream* nil "This variable is bound to the transaction log stream while loading the transaction log. It is used by anonymous transactions to read the subtransactions from the log.") (defmethod decode-object ((tag (eql #\N)) stream) - ;; When decoding an anonymous transaction from the transaction log, - ;; we only read its name. The subtransaction are not read here, but - ;; rather in EXECUTE-UNLOGGED below. The reason for this is that we - ;; need to execute the subtransactions while reading them, as we'd - ;; otherwise not be able to properly deserialize references to - ;; objects that have been created within this anonymous transaction. + (let* ((label (%decode-string stream)) + (length (%decode-integer stream)) + (buffer (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence buffer stream) + (make-instance 'anonymous-transaction + :label label + :log-buffer (flex:make-in-memory-input-stream buffer)))) - ;; Thus, while restoring, the TRANSACTIONS slot of the anonymous - ;; transaction object is not used. - (make-instance 'anonymous-transaction - :label (%decode-string stream))) - (defmacro with-transaction ((&optional label) &body body) (let ((txn (gensym))) `(progn (when (in-transaction-p) - (error "tried to start anonymous transaction while in a transaction")) + (error 'anonymous-transaction-in-named-transaction)) (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) (with-transaction-log (,txn) ,@body))))) @@ -537,15 +584,14 @@ ;; subtransactions from the transaction log. (assert (eq :restore (store-state *store*)) () "Unexpected store state ~A for EXECUTE-UNLOGGED on an anonymous transaction" (store-state *store*)) - (let ((subtxns (%decode-integer *txn-log-stream*))) - (dotimes (i subtxns) - (execute-unlogged (decode *txn-log-stream*))) - (when (plusp subtxns) - ;; In order to maintain the previous on-disk format, we read the last cdr of the list - (assert (eq nil (decode *txn-log-stream*)))))) + (let ((stream (anonymous-transaction-log-buffer transaction))) + (handler-case + (loop + (execute-unlogged (decode stream))) + (end-of-file ())))) -(defmethod execute-transaction :after ((executor anonymous-transaction) transaction) - (push transaction (anonymous-transaction-transactions executor))) +(defmethod execute-transaction :before ((executor anonymous-transaction) transaction) + (encode transaction (anonymous-transaction-log-buffer executor))) ;;; Subsystems @@ -571,9 +617,9 @@ (defmethod snapshot-store ((store store)) (unless (store-open-p) - (error (make-condition 'store-not-open))) + (error 'store-not-open)) (when (null (store-subsystems store)) - (error "Cannot snapshot store without subsystems...")) + (error 'no-subsystems)) (ensure-store-current-directory store) (with-store-state (:read-only store) (with-store-guard ()

1 0

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

29 Jul '08

Revision: 3681 Author: ksprotte URL: http://bknr.net/trac/changeset/3681 checkpoint U trunk/projects/bos/m2/contract-expiry.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/test/allocation.lisp U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/reports-xml-handler.lisp Modified: trunk/projects/bos/m2/contract-expiry.lisp =================================================================== --- trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -1,7 +1,7 @@ (in-package :bos.m2) (defun delete-expired-contracts () - (let ((unpaid-contracts (remove-if #'contract-paidp (class-instances 'contract))) + (let ((unpaid-contracts (remove-if #'contract-paidp (all-contracts))) deleting) (dolist (contract unpaid-contracts) (when (contract-is-expired contract) Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/m2.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -257,7 +257,9 @@ (download-only :update) (cert-issued :read) (worldpay-trans-id :update :initform nil) - (expires :read :documentation "universal time which specifies the time the contract expires (is deleted) when it has not been paid for" :initform nil) + (expires :read :documentation "universal time which specifies the + time the contract expires (is deleted) when it has not been paid for" + :initform nil) (largest-rectangle :update)) (:default-initargs :m2s nil @@ -379,7 +381,7 @@ (defun all-contracts () "Return list of all contracts in the system." - (class-instances 'all-contracts)) + (class-instances 'contract)) (defun contracts-bounding-box (&optional (contracts (all-contracts))) (geometry:with-bounding-box-collect (collect) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/packages.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -139,6 +139,7 @@ #:contract #:make-contract + #:all-contracts #:contract-p #:get-contract #:contract-sponsor Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -28,20 +28,20 @@ (define-persistent-class poi-medium (textual-attributes-mixin) ((poi :read))) -(deftransaction make-poi-medium (class-name &key language title subtitle description poi initargs) +(deftransaction make-poi-medium (class-name &rest rest &key language title subtitle description poi initargs) + (declare (ignore poi initargs)) (assert (if (or title subtitle description) language t) nil "language needs to be specified, if any of title, subtitle or description is given") - (let ((medium (apply #'make-object class-name :poi poi initargs))) - (update-textual-attributes medium language - :title title - :subtitle subtitle - :description description) - medium)) + (apply #'make-object class-name rest)) (defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) - (when (poi-medium-poi poi-medium) - (push poi-medium (poi-media (poi-medium-poi poi-medium))))) + (when poi + (push poi-medium (poi-media poi))) + (update-textual-attributes poi-medium language + :title title + :subtitle subtitle + :description description)) (defmethod print-object ((object poi-medium) stream) (print-unreadable-object (object stream :type t :identity nil) @@ -56,6 +56,14 @@ (define-persistent-class poi-image (store-image poi-medium) ()) +;;; poi-airal +(define-persistent-class poi-airal (store-image poi-medium) + ()) + +;;; poi-panorama +(define-persistent-class poi-panorama (store-image poi-medium) + ()) + ;;; poi-movie (define-persistent-class poi-movie (poi-medium) ((url :update :initform nil))) @@ -65,10 +73,10 @@ ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") - (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") + (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") - (icon :update :initform "palme" :documentation "Name des Icons") - (media :update :initform nil))) + (icon :update :initform "palme" :documentation "Name des Icons") + (media :update :initform nil :documentation "Liste aller POI-Medien, wie POI-IMAGE, POI-AIRAL ..."))) (deftransaction make-poi (language name &key title description area) (let ((poi (make-object 'poi :name name :area area))) @@ -76,12 +84,18 @@ (setf (slot-string poi 'description language) description) poi)) +(defmethod initialize-persistent-instance :after ((poi poi) &key language title subtitle description) + (update-textual-attributes poi language + :title title + :subtitle subtitle + :description description)) + (defmethod destroy-object :before ((poi poi)) (mapc #'delete-object (poi-media poi))) (defmethod poi-complete ((poi poi) language) (and (every #'(lambda (slot-name) (slot-string poi slot-name language nil)) '(title subtitle description)) - (poi-area poi) + (poi-area poi) (<= 6 (count-if (lambda (medium) (typep medium 'poi-image)) (poi-media poi))) t)) @@ -94,6 +108,16 @@ (defun poi-center-lon-lat (poi) (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ (poi-center-x poi)) (- +nw-utm-y+ (poi-center-y poi)) +utm-zone+ t)) +(macrolet ((define-poi-medium-reader (name) + (let ((type (find-symbol (subseq (symbol-name name) 0 (1- (length (symbol-name name))))))) + (assert type) + `(defun ,name (poi) + (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))))) + (define-poi-medium-reader poi-images) + (define-poi-medium-reader poi-airals) + (define-poi-medium-reader poi-panoramas) + (define-poi-medium-reader poi-movies)) + (defun make-poi-javascript (language) "Erzeugt das POI-Javascript für das Infosystem" (with-output-to-string (*standard-output*) @@ -148,3 +172,19 @@ (format t "poi['y'] = ~D;~%" y) (format t "poi['thumbnail'] = 0;~%") (format t "pois.push(poi);~%"))))) + +;;; poi schema evolution aids + +(define-modify-macro appendf (&rest args) append) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'airals)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-airal :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'images)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-image :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'movies)) value) + (appendf (poi-media poi) (mapcar (lambda (url) (make-instance 'poi-movie :url url :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'panoramas)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-panorama :poi poi)) value))) Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/test/allocation.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -83,7 +83,7 @@ (with-transaction () (iter (while (> size total-free)) - (for contract = (first (class-instances 'contract))) + (for contract = (first (all-contracts))) (incf total-free (length (contract-m2s contract))) (destroy-object contract))) (finishes (make-contract sponsor size)) Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -355,7 +355,7 @@ ;; has already been called :base-node *quad-tree* :name '*contract-tree*)) - (dolist (contract (class-instances 'contract)) + (dolist (contract (all-contracts)) (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -249,7 +249,7 @@ ()) (defmethod handle ((handler country-stats-handler)) - (let* ((contracts (class-instances 'contract)) + (let* ((contracts (all-contracts)) (timestamp (reduce #'max contracts :key (lambda (contract) (if (contract-paidp contract) (store-object-last-change contract 0) Modified: trunk/projects/bos/web/reports-xml-handler.lisp =================================================================== --- trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -32,7 +32,7 @@ (or (not (contract-paidp contract)) (and *year* (not (eql *year* (contract-year contract)))))) - (class-instances 'contract)) + (all-contracts)) #'< :key #'contract-date))) (setf name (intern (string-upcase name) :bos.web)) (apply (or (gethash name *report-generators*)

1 0

[bknr-cvs] ksprotte changed trunk/
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3680 Author: ksprotte URL: http://bknr.net/trac/changeset/3680 add &allow-other-keys to initialize-persistent-instance for now U trunk/bknr/datastore/src/data/object.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/m2/slot-strings.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:30:55 UTC (rev 3679) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:56:24 UTC (rev 3680) @@ -244,7 +244,7 @@ :timestamp (get-universal-time) :args (append (list object (if (symbolp class) class (class-name class))) args)))) -(defgeneric initialize-persistent-instance (store-object &key) +(defgeneric initialize-persistent-instance (store-object &key &allow-other-keys) (:documentation "Initializes the persistent aspects of a persistent object. This method is called at the creation of a persistent object, but not when Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:30:55 UTC (rev 3679) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 12:56:24 UTC (rev 3680) @@ -7,68 +7,69 @@ ;;; POI-Anwendungsklassen und Konstruktoren -;;; poi-image -(define-persistent-class poi-image (store-image) - ((poi :read) - (title :update :initform (make-string-hash-table)) - (subtitle :update :initform (make-string-hash-table)) - (description :update :initform (make-string-hash-table)))) +;;; textual-attributes-mixin +(define-persistent-class textual-attributes-mixin () + ((title :update :initform (make-string-hash-table) + :documentation "Angezeigter Name") + (subtitle :update :initform (make-string-hash-table) + :documentation "Unterschrift") + (description :update :initform (make-string-hash-table) + :documentation "Beschreibungstext"))) -(defmethod print-object ((object poi-image) stream) +(deftransaction update-textual-attributes (obj language &key title subtitle description) + (when title + (setf (slot-string obj 'title language) title)) + (when subtitle + (setf (slot-string obj 'subtitle language) subtitle)) + (when description + (setf (slot-string obj 'description language) description))) + +;;; poi-medium +(define-persistent-class poi-medium (textual-attributes-mixin) + ((poi :read))) + +(deftransaction make-poi-medium (class-name &key language title subtitle description poi initargs) + (assert (if (or title subtitle description) language t) nil + "language needs to be specified, if any of title, subtitle + or description is given") + (let ((medium (apply #'make-object class-name :poi poi initargs))) + (update-textual-attributes medium language + :title title + :subtitle subtitle + :description description) + medium)) + +(defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) + (when (poi-medium-poi poi-medium) + (push poi-medium (poi-media (poi-medium-poi poi-medium))))) + +(defmethod print-object ((object poi-medium) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~D" (store-object-id object)))) -(deftransaction make-poi-image (language &key title subtitle description poi) - (let ((poi-image (make-object 'poi-image :poi poi))) - (setf (slot-string poi-image 'title language) title) - (setf (slot-string poi-image 'subtitle language) subtitle) - (setf (slot-string poi-image 'description language) description) - poi-image)) - -(defmethod destroy-object :before ((poi-image poi-image)) - (with-slots (poi) poi-image +(defmethod destroy-object :before ((poi-medium poi-medium)) + (with-slots (poi) poi-medium (when poi - (setf (poi-images poi) (remove poi-image (poi-images poi)))))) + (setf (poi-media poi) (remove poi-medium (poi-media poi)))))) -(defmethod initialize-persistent-instance :after ((poi-image poi-image) &key) - (setf (poi-images (poi-image-poi poi-image)) (append (poi-images (poi-image-poi poi-image)) (list poi-image)))) +;;; poi-image +(define-persistent-class poi-image (store-image poi-medium) + ()) -(deftransaction update-poi-image (poi-image language - &key title subtitle description) - (when title - (setf (slot-string poi-image 'title language) title)) - (when subtitle - (setf (slot-string poi-image 'subtitle language) subtitle)) - (when description - (setf (slot-string poi-image 'description language) description))) - ;;; poi-movie -(define-persistent-class poi-movie () - ((poi :read) - (url :update :initform nil))) +(define-persistent-class poi-movie (poi-medium) + ((url :update :initform nil))) ;;; poi -(define-persistent-class poi () +(define-persistent-class poi (textual-attributes-mixin) ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") - (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") - (title :update :initform (make-string-hash-table) :documentation "Angezeigter Name") - (subtitle :update :initform (make-string-hash-table) :documentation "Unterschrift") - (description :update :initform (make-string-hash-table) :documentation "Beschreibungstext") + (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") (icon :update :initform "palme" :documentation "Name des Icons") - (medias :update :initform nil))) + (media :update :initform nil))) -(defmethod poi-movies :before ((poi poi)) - "Lazily update the db schema. Method can be removed later." - (macrolet ((movie (tail) `(car ,tail))) - (mapl (lambda (tail) - (when (stringp (movie tail)) - (setf (movie tail) - (make-object 'poi-movie :poi poi :url (movie tail))))) - (slot-value poi 'movies)))) - (deftransaction make-poi (language name &key title description area) (let ((poi (make-object 'poi :name name :area area))) (setf (slot-string poi 'title language) title) @@ -76,32 +77,14 @@ poi)) (defmethod destroy-object :before ((poi poi)) - (mapc #'delete-object (poi-images poi))) + (mapc #'delete-object (poi-media poi))) (defmethod poi-complete ((poi poi) language) (and (every #'(lambda (slot-name) (slot-string poi slot-name language nil)) '(title subtitle description)) - (poi-area poi) - (poi-images poi) + (poi-area poi) + (<= 6 (count-if (lambda (medium) (typep medium 'poi-image)) (poi-media poi))) t)) -(defun update-poi (poi language &key title subtitle description area icon published (images :not-set) (movies :not-set)) - (with-transaction () - (setf (slot-value poi 'published) published) - (when title - (setf (slot-string poi 'title language) title)) - (when subtitle - (setf (slot-string poi 'subtitle language) subtitle)) - (when description - (setf (slot-string poi 'description language) description)) - (when area - (setf (poi-area poi) area)) - (when icon - (setf (poi-icon poi) icon)) - (when (listp images) - (setf (poi-images poi) images)) - (when (listp movies) - (setf (poi-movies poi) movies)))) - (defmethod poi-center-x ((poi poi)) (first (poi-area poi))) Modified: trunk/projects/bos/m2/slot-strings.lisp =================================================================== --- trunk/projects/bos/m2/slot-strings.lisp 2008-07-29 12:30:55 UTC (rev 3679) +++ trunk/projects/bos/m2/slot-strings.lisp 2008-07-29 12:56:24 UTC (rev 3680) @@ -17,7 +17,8 @@ (defun set-slot-string (object slot-name language new-value) (unless (in-transaction-p) - (error "attempt to set string in multi-language string slot ~a of object ~a outside of transaction" slot-name object)) + (error "attempt to set string in multi-language string slot ~a of ~ + object ~a outside of transaction" slot-name object)) (setf (gethash language (slot-value object slot-name)) new-value)) (defsetf slot-string set-slot-string)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/poi.lisp
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3679 Author: hans URL: http://bknr.net/trac/changeset/3679 Remove accidentially duplicated slot PUBLISHED from POI U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:21:03 UTC (rev 3678) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 12:30:55 UTC (rev 3679) @@ -49,11 +49,10 @@ ;;; poi (define-persistent-class poi () - ((published :update :initform nil) - (name :read :index-type string-unique-index + ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") - (published :update :initform nil) + (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") (title :update :initform (make-string-hash-table) :documentation "Angezeigter Name") (subtitle :update :initform (make-string-hash-table) :documentation "Unterschrift") (description :update :initform (make-string-hash-table) :documentation "Beschreibungstext")

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3678 Author: hans URL: http://bknr.net/trac/changeset/3678 Fix a few more methods for INITIALIZE-PERSISTENT-INSTANCE to include &KEY. U trunk/bknr/modules/text/article.lisp U trunk/projects/lisp-ecoop/src/participant.lisp U trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp U trunk/projects/unmaintained/raw-data/mcp/sensors.lisp Modified: trunk/bknr/modules/text/article.lisp =================================================================== --- trunk/bknr/modules/text/article.lisp 2008-07-29 12:13:33 UTC (rev 3677) +++ trunk/bknr/modules/text/article.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -36,7 +36,7 @@ (article-subject article) " " (article-text article)))) -(defmethod initialize-persistent-instance :after ((article article)) +(defmethod initialize-persistent-instance :after ((article article) &key) (setf (article-search-vector article) (article-to-search-vector article))) Modified: trunk/projects/lisp-ecoop/src/participant.lisp =================================================================== --- trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-29 12:13:33 UTC (rev 3677) +++ trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -7,7 +7,7 @@ (submission :read :documentation "Submission that this document belongs to")) (:default-initargs :type "application/pdf" :submission (error ":submission argument missing while creating document"))) -(defmethod initialize-persistent-instance :after ((document document)) +(defmethod initialize-persistent-instance :after ((document document) &key) (with-slots (submission) document (push document (submission-documents submission)))) @@ -92,7 +92,7 @@ #'(lambda (&rest more) (apply fun (append args more)))) -(defmethod initialize-persistent-instance :after ((participant participant)) +(defmethod initialize-persistent-instance :after ((participant participant) &key) (make-email-list)) (defun make-email-list () Modified: trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp =================================================================== --- trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-29 12:13:33 UTC (rev 3677) +++ trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -88,7 +88,7 @@ ((device :initarg :device :reader bluetooth-event-device)) (:metaclass persistent-class)) -(defmethod initialize-persistent-instance :after ((event bluetooth-event)) +(defmethod initialize-persistent-instance :after ((event bluetooth-event) &key) (with-slots (device) event (push event (bluetooth-device-events device)) (setf (sample-event-value event) (or (bluetooth-device-name device) (bluetooth-device-mac-address device))))) Modified: trunk/projects/unmaintained/raw-data/mcp/sensors.lisp =================================================================== --- trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-29 12:13:33 UTC (rev 3677) +++ trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -60,7 +60,7 @@ (defmethod sample-event-table-name ((sensor sensor)) (format nil "sample_event_~(~A~)" (sensor-type sensor))) -(defmethod initialize-persistent-instance :after ((sensor sensor)) +(defmethod initialize-persistent-instance :after ((sensor sensor) &key) (let ((id (store-object-id sensor))) (with-slots (name unit type) sensor (postgres-execute

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3677 Author: hans URL: http://bknr.net/trac/changeset/3677 INITIALIZE-PERSISTENT-INSTANCE now receives the initargs supplied to MAKE-OBJECT. U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/web/src/frontend/frontend-config.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/bknr/web/src/sysclasses/user.lisp U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/poi.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -244,19 +244,19 @@ :timestamp (get-universal-time) :args (append (list object (if (symbolp class) class (class-name class))) args)))) -(defgeneric initialize-persistent-instance (store-object) +(defgeneric initialize-persistent-instance (store-object &key) (:documentation - "Initializes the persistent aspects of a persistent object. This method is called -at the creationg of a persistent object, but not when the object is loaded from a -snapshot.")) + "Initializes the persistent aspects of a persistent object. This +method is called at the creation of a persistent object, but not when +the object is loaded from a snapshot.")) (defgeneric initialize-transient-instance (store-object) (:documentation - "Initializes the transient aspects of a persistent object. This method is called -whenever a persistent object is initialized, also when the object is loaded from -a snapshot.")) + "Initializes the transient aspects of a persistent object. This +method is called whenever a persistent object is initialized, also +when the object is loaded from a snapshot.")) -(defmethod initialize-persistent-instance ((object store-object))) +(defmethod initialize-persistent-instance ((object store-object) &key)) (defmethod initialize-transient-instance ((object store-object))) (defmethod store-object-persistent-slots ((object store-object)) @@ -641,7 +641,7 @@ (if restoring (remove-transient-slot-initargs (find-class class-name) initargs) initargs))) - (initialize-persistent-instance obj) + (apply #'initialize-persistent-instance obj initargs) (initialize-transient-instance obj) (setf error nil) obj) Modified: trunk/bknr/web/src/frontend/frontend-config.lisp =================================================================== --- trunk/bknr/web/src/frontend/frontend-config.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/web/src/frontend/frontend-config.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -9,7 +9,8 @@ (cl-interpol:disable-interpol-syntax)))) (defun cachable-prefixes-regex () - (format nil "^(~{~A~^|~})" (mapcar #'page-handler-prefix (website-cachable-handlers bknr.web:*website*)))) + (format nil "^(~{~A~^|~})" + (mapcar #'page-handler-prefix (website-cachable-handlers bknr.web::*website*)))) (defun generate-frontend-config (stream &key backend-port) Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -147,7 +147,7 @@ (:method ((channel (eql nil)) item) (warn "no RSS channel defined for item ~A" item))) -(defmethod initialize-persistent-instance :after ((rss-item rss-item)) +(defmethod initialize-persistent-instance :after ((rss-item rss-item) &key) (add-item (rss-item-channel rss-item) rss-item)) (defmethod destroy-object :before ((rss-item rss-item)) Modified: trunk/bknr/web/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/web/src/sysclasses/user.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -60,7 +60,7 @@ (user-login object) "unbound")))) -(defmethod initialize-persistent-instance ((user user)) +(defmethod initialize-persistent-instance ((user user) &key) (let* ((plaintext-password (slot-value user 'password)) (password (when plaintext-password (crypt-md5 plaintext-password (make-salt))))) (setf (slot-value user 'password) password))) @@ -72,7 +72,7 @@ (define-persistent-class smb-user (user) ()) -(defmethod initialize-persistent-instance ((user smb-user)) +(defmethod initialize-persistent-instance ((user smb-user) &key) (let* ((plaintext-password (slot-value user 'password))) (when plaintext-password (set-smb-password (user-login user) plaintext-password)) Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -34,7 +34,7 @@ :unbound) (store-object-id allocation-area)))) -(defmethod initialize-persistent-instance :after ((allocation-area allocation-area)) +(defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key) (with-slots (total-m2s free-m2s) allocation-area (setf total-m2s (calculate-total-m2-count allocation-area)) (setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area)))) Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/projects/bos/m2/m2.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -276,7 +276,7 @@ (defun contract-p (object) (equal (class-of object) (find-class 'contract))) -(defmethod initialize-persistent-instance :after ((contract contract)) +(defmethod initialize-persistent-instance :after ((contract contract) &key) (pushnew contract (sponsor-contracts (contract-sponsor contract))) (dolist (m2 (contract-m2s contract)) (setf (m2-contract m2) contract)) @@ -377,7 +377,11 @@ (dolist (m2 (contract-m2s contract)) (collect (list (m2-x m2) (m2-y m2)))))) -(defun contracts-bounding-box (&optional (contracts (class-instances 'contract))) +(defun all-contracts () + "Return list of all contracts in the system." + (class-instances 'all-contracts)) + +(defun contracts-bounding-box (&optional (contracts (all-contracts))) (geometry:with-bounding-box-collect (collect) (dolist (contract contracts) (dolist (m2 (contract-m2s contract)) Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -30,7 +30,7 @@ (when poi (setf (poi-images poi) (remove poi-image (poi-images poi)))))) -(defmethod initialize-persistent-instance :after ((poi-image poi-image)) +(defmethod initialize-persistent-instance :after ((poi-image poi-image) &key) (setf (poi-images (poi-image-poi poi-image)) (append (poi-images (poi-image-poi poi-image)) (list poi-image)))) (deftransaction update-poi-image (poi-image language @@ -53,6 +53,7 @@ (name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") + (published :update :initform nil) (title :update :initform (make-string-hash-table) :documentation "Angezeigter Name") (subtitle :update :initform (make-string-hash-table) :documentation "Unterschrift") (description :update :initform (make-string-hash-table) :documentation "Beschreibungstext")

1 0

[bknr-cvs] hans changed trunk/projects/bos/web/countries.lisp
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3676 Author: hans URL: http://bknr.net/trac/changeset/3676 Move LABELS into value position in order to preserve top-levelness of DEFVAR. U trunk/projects/bos/web/countries.lisp Modified: trunk/projects/bos/web/countries.lisp =================================================================== --- trunk/projects/bos/web/countries.lisp 2008-07-29 10:06:05 UTC (rev 3675) +++ trunk/projects/bos/web/countries.lisp 2008-07-29 12:09:21 UTC (rev 3676) @@ -4,98 +4,99 @@ (in-package :bos.web) -(labels ((degrees2float (string) - (ppcre:register-groups-bind (degrees minutes orientation) - ("(\\d+) +(\\d+) +([WESN])" string) - (assert (and degrees minutes orientation)) - (* (case (char orientation 0) ((#\W #\S) -1d0) (otherwise 1d0)) - (+ (float (parse-integer degrees) 0d0) - (/ (float (parse-integer minutes) 0d0) 60d0))))) - (parse-coord (args) - (destructuring-bind (country lon lat) - args - (list country (degrees2float lon) (degrees2float lat))))) - (defvar *country-coords* (mapcar #'parse-coord - '((:AW "12 30 N" "69 58 W") (:AG "17 03 N" "61 48 W") (:AE "24 00 N" "54 00 E") - (:AF "33 00 N" "65 00 E") (:DZ "28 00 N" "3 00 E") (:AZ "40 30 N" "47 30 E") - (:AL "41 00 N" "20 00 E") (:AM "40 00 N" "45 00 E") (:AD "42 30 N" "1 30 E") - (:AO "12 30 S" "18 30 E") (:AS "14 20 S" "170 00 W") (:AR "34 00 S" "64 00 W") - (:AU "27 00 S" "133 00 E") (:AT "47 20 N" "13 20 E") (:AI "18 15 N" "63 10 W") - (:AQ "90 00 S" "0 00 E") (:BH "26 00 N" "50 33 E") (:BB "13 10 N" "59 32 W") - (:BW "22 00 S" "24 00 E") (:BM "32 20 N" "64 45 W") (:BE "50 50 N" "4 00 E") - (:BS "24 15 N" "76 00 W") (:BD "24 00 N" "90 00 E") (:BZ "17 15 N" "88 45 W") - (:BA "44 00 N" "18 00 E") (:BO "17 00 S" "65 00 W") (:MM "22 00 N" "98 00 E") - (:BJ "9 30 N" "2 15 E") (:BY "53 00 N" "28 00 E") (:SB "8 00 S" "159 00 E") - (:BR "10 00 S" "55 00 W") (:BT "27 30 N" "90 30 E") (:BG "43 00 N" "25 00 E") - (:BV "54 26 S" "3 24 E") (:BN "4 30 N" "114 40 E") (:BI "3 30 S" "30 00 E") - (:CA "60 00 N" "95 00 W") (:KH "13 00 N" "105 00 E") (:TD "15 00 N" "19 00 E") - (:LK "7 00 N" "81 00 E") (:CG "1 00 S" "15 00 E") (:CD "0 00 N" "25 00 E") - (:CN "35 00 N" "105 00 E") (:CL "30 00 S" "71 00 W") (:KY "19 30 N" "80 30 W") - (:CC "12 30 S" "96 50 E") (:CM "6 00 N" "12 00 E") (:KM "12 10 S" "44 15 E") - (:CO "4 00 N" "72 00 W") (:MP "15 12 N" "145 45 E") (:CR "10 00 N" "84 00 W") - (:CF "7 00 N" "21 00 E") (:CU "21 30 N" "80 00 W") (:CV "16 00 N" "24 00 W") - (:CK "21 14 S" "159 46 W") (:CY "35 00 N" "33 00 E") (:DK "56 00 N" "10 00 E") - (:DJ "11 30 N" "43 00 E") (:DM "15 25 N" "61 20 W") (:DO "19 00 N" "70 40 W") - (:EC "2 00 S" "77 30 W") (:EG "27 00 N" "30 00 E") (:IE "53 00 N" "8 00 W") - (:GQ "2 00 N" "10 00 E") (:EE "59 00 N" "26 00 E") (:ER "15 00 N" "39 00 E") - (:SV "13 50 N" "88 55 W") (:ET "8 00 N" "38 00 E") (:CZ "49 45 N" "15 30 E") - (:FI "64 00 N" "26 00 E") (:FJ "18 00 S" "175 00 E") (:FK "51 45 S" "59 00 W") - (:FM "6 55 N" "158 15 E") (:FO "62 00 N" "7 00 W") (:PF "15 00 S" "140 00 W") - (:FR "46 00 N" "2 00 E") (:GM "13 28 N" "16 34 W") (:GA "1 00 S" "11 45 E") - (:GE "42 00 N" "43 30 E") (:GH "8 00 N" "2 00 W") (:GI "36 08 N" "5 21 W") - (:GD "12 07 N" "61 40 W") (:GG "49 28 N" "2 35 W") (:GL "72 00 N" "40 00 W") - (:DE "51 00 N" "9 00 E") (:GU "13 28 N" "144 47 E") (:GR "39 00 N" "22 00 E") - (:GT "15 30 N" "90 15 W") (:GN "11 00 N" "10 00 W") (:GY "5 00 N" "59 00 W") - (:PS "31 25 N" "34 20 E") (:HT "19 00 N" "72 25 W") (:HK "22 15 N" "114 10 E") - (:HM "53 06 S" "72 31 E") (:HN "15 00 N" "86 30 W") (:HR "45 10 N" "15 30 E") - (:HU "47 00 N" "20 00 E") (:IS "65 00 N" "18 00 W") (:ID "5 00 S" "120 00 E") - (:IM "54 15 N" "4 30 W") (:IN "20 00 N" "77 00 E") (:IO "6 00 S" "71 30 E") - (:IR "32 00 N" "53 00 E") (:IL "31 30 N" "34 45 E") (:IT "42 50 N" "12 50 E") - (:CI "8 00 N" "5 00 W") (:IQ "33 00 N" "44 00 E") (:JP "36 00 N" "138 00 E") - (:JE "49 15 N" "2 10 W") (:JM "18 15 N" "77 30 W") (:JO "31 00 N" "36 00 E") - (:KE "1 00 N" "38 00 E") (:KG "41 00 N" "75 00 E") (:KP "40 00 N" "127 00 E") - (:KI "1 25 N" "173 00 E") (:KR "37 00 N" "127 30 E") - (:CX "10 30 S" "105 40 E") (:KW "29 30 N" "45 45 E") (:KZ "48 00 N" "68 00 E") - (:LA "18 00 N" "105 00 E") (:LB "33 50 N" "35 50 E") (:LV "57 00 N" "25 00 E") - (:LT "56 00 N" "24 00 E") (:LR "6 30 N" "9 30 W") (:SK "48 40 N" "19 30 E") - (:LI "47 16 N" "9 32 E") (:LS "29 30 S" "28 30 E") (:LU "49 45 N" "6 10 E") - (:LY "25 00 N" "17 00 E") (:MG "20 00 S" "47 00 E") (:MO "22 10 N" "113 33 E") - (:MD "47 00 N" "29 00 E") (:YT "12 50 S" "45 10 E") (:MN "46 00 N" "105 00 E") - (:MS "16 45 N" "62 12 W") (:MW "13 30 S" "34 00 E") (:ME "42 30 N" "19 18 E") - (:MK "41 50 N" "22 00 E") (:ML "17 00 N" "4 00 W") (:MC "43 44 N" "7 24 E") - (:MA "32 00 N" "5 00 W") (:MU "20 17 S" "57 33 E") (:MR "20 00 N" "12 00 W") - (:MT "35 50 N" "14 35 E") (:OM "21 00 N" "57 00 E") (:MV "3 15 N" "73 00 E") - (:MX "23 00 N" "102 00 W") (:MY "2 30 N" "112 30 E") (:MZ "18 15 S" "35 00 E") - (:NC "21 30 S" "165 30 E") (:NU "19 02 S" "169 52 W") - (:NF "29 02 S" "167 57 E") (:NE "16 00 N" "8 00 E") (:VU "16 00 S" "167 00 E") - (:NG "10 00 N" "8 00 E") (:NL "52 30 N" "5 45 E") (:NO "62 00 N" "10 00 E") - (:NP "28 00 N" "84 00 E") (:NR "0 32 S" "166 55 E") (:SR "4 00 N" "56 00 W") - (:AN "12 15 N" "68 45 W") (:NI "13 00 N" "85 00 W") (:NZ "41 00 S" "174 00 E") - (:PY "23 00 S" "58 00 W") (:PN "25 04 S" "130 06 W") (:PE "10 00 S" "76 00 W") - (:PK "30 00 N" "70 00 E") (:PL "52 00 N" "20 00 E") (:PA "9 00 N" "80 00 W") - (:PT "39 30 N" "8 00 W") (:PG "6 00 S" "147 00 E") (:PW "7 30 N" "134 30 E") - (:GW "12 00 N" "15 00 W") (:QA "25 30 N" "51 15 E") (:RS "44 00 N" "21 00 E") - (:MH "9 00 N" "168 00 E") (:MF "18 05 N" "63 57 W") (:RO "46 00 N" "25 00 E") - (:PH "13 00 N" "122 00 E") (:PR "18 15 N" "66 30 W") - (:RU "60 00 N" "100 00 E") (:RW "2 00 S" "30 00 E") (:SA "25 00 N" "45 00 E") - (:PM "46 50 N" "56 20 W") (:KN "17 20 N" "62 45 W") (:SC "4 35 S" "55 40 E") - (:ZA "29 00 S" "24 00 E") (:SN "14 00 N" "14 00 W") (:SI "46 07 N" "14 49 E") - (:SL "8 30 N" "11 30 W") (:SM "43 46 N" "12 25 E") (:SG "1 22 N" "103 48 E") - (:SO "10 00 N" "49 00 E") (:ES "40 00 N" "4 00 W") (:LC "13 53 N" "60 58 W") - (:SD "15 00 N" "30 00 E") (:SJ "78 00 N" "20 00 E") (:SE "62 00 N" "15 00 E") - (:GS "54 30 S" "37 00 W") (:SY "35 00 N" "38 00 E") (:CH "47 00 N" "8 00 E") - (:BL "17 90 N" "62 85 W") (:TT "11 00 N" "61 00 W") (:TH "15 00 N" "100 00 E") - (:TJ "39 00 N" "71 00 E") (:TC "21 45 N" "71 35 W") (:TK "9 00 S" "172 00 W") - (:TO "20 00 S" "175 00 W") (:TG "8 00 N" "1 10 E") (:ST "1 00 N" "7 00 E") - (:TN "34 00 N" "9 00 E") (:TL "8 50 S" "125 55 E") (:TR "39 00 N" "35 00 E") - (:TV "8 00 S" "178 00 E") (:TW "23 30 N" "121 00 E") (:TM "40 00 N" "60 00 E") - (:TZ "6 00 S" "35 00 E") (:UG "1 00 N" "32 00 E") (:GB "54 00 N" "2 00 W") - (:UA "49 00 N" "32 00 E") (:US "38 00 N" "97 00 W") (:BF "13 00 N" "2 00 W") - (:UY "33 00 S" "56 00 W") (:UZ "41 00 N" "64 00 E") (:VC "13 15 N" "61 12 W") - (:VE "8 00 N" "66 00 W") (:VG "18 30 N" "64 30 W") (:VN "16 00 N" "106 00 E") - (:VI "18 20 N" "64 50 W") (:VA "41 54 N" "12 27 E") (:NA "22 00 S" "17 00 E") - (:PS "32 00 N" "35 15 E") (:WF "13 18 S" "176 12 W") (:EH "24 30 N" "13 00 W") - (:WS "13 35 S" "172 20 W") (:SZ "26 30 S" "31 30 E") (:YE "15 00 N" "48 00 E"))))) +(defvar *country-coords* + (labels ((degrees2float (string) + (ppcre:register-groups-bind (degrees minutes orientation) + ("(\\d+) +(\\d+) +([WESN])" string) + (assert (and degrees minutes orientation)) + (* (case (char orientation 0) ((#\W #\S) -1d0) (otherwise 1d0)) + (+ (float (parse-integer degrees) 0d0) + (/ (float (parse-integer minutes) 0d0) 60d0))))) + (parse-coord (args) + (destructuring-bind (country lon lat) + args + (list country (degrees2float lon) (degrees2float lat))))) + (mapcar #'parse-coord + '((:AW "12 30 N" "69 58 W") (:AG "17 03 N" "61 48 W") (:AE "24 00 N" "54 00 E") + (:AF "33 00 N" "65 00 E") (:DZ "28 00 N" "3 00 E") (:AZ "40 30 N" "47 30 E") + (:AL "41 00 N" "20 00 E") (:AM "40 00 N" "45 00 E") (:AD "42 30 N" "1 30 E") + (:AO "12 30 S" "18 30 E") (:AS "14 20 S" "170 00 W") (:AR "34 00 S" "64 00 W") + (:AU "27 00 S" "133 00 E") (:AT "47 20 N" "13 20 E") (:AI "18 15 N" "63 10 W") + (:AQ "90 00 S" "0 00 E") (:BH "26 00 N" "50 33 E") (:BB "13 10 N" "59 32 W") + (:BW "22 00 S" "24 00 E") (:BM "32 20 N" "64 45 W") (:BE "50 50 N" "4 00 E") + (:BS "24 15 N" "76 00 W") (:BD "24 00 N" "90 00 E") (:BZ "17 15 N" "88 45 W") + (:BA "44 00 N" "18 00 E") (:BO "17 00 S" "65 00 W") (:MM "22 00 N" "98 00 E") + (:BJ "9 30 N" "2 15 E") (:BY "53 00 N" "28 00 E") (:SB "8 00 S" "159 00 E") + (:BR "10 00 S" "55 00 W") (:BT "27 30 N" "90 30 E") (:BG "43 00 N" "25 00 E") + (:BV "54 26 S" "3 24 E") (:BN "4 30 N" "114 40 E") (:BI "3 30 S" "30 00 E") + (:CA "60 00 N" "95 00 W") (:KH "13 00 N" "105 00 E") (:TD "15 00 N" "19 00 E") + (:LK "7 00 N" "81 00 E") (:CG "1 00 S" "15 00 E") (:CD "0 00 N" "25 00 E") + (:CN "35 00 N" "105 00 E") (:CL "30 00 S" "71 00 W") (:KY "19 30 N" "80 30 W") + (:CC "12 30 S" "96 50 E") (:CM "6 00 N" "12 00 E") (:KM "12 10 S" "44 15 E") + (:CO "4 00 N" "72 00 W") (:MP "15 12 N" "145 45 E") (:CR "10 00 N" "84 00 W") + (:CF "7 00 N" "21 00 E") (:CU "21 30 N" "80 00 W") (:CV "16 00 N" "24 00 W") + (:CK "21 14 S" "159 46 W") (:CY "35 00 N" "33 00 E") (:DK "56 00 N" "10 00 E") + (:DJ "11 30 N" "43 00 E") (:DM "15 25 N" "61 20 W") (:DO "19 00 N" "70 40 W") + (:EC "2 00 S" "77 30 W") (:EG "27 00 N" "30 00 E") (:IE "53 00 N" "8 00 W") + (:GQ "2 00 N" "10 00 E") (:EE "59 00 N" "26 00 E") (:ER "15 00 N" "39 00 E") + (:SV "13 50 N" "88 55 W") (:ET "8 00 N" "38 00 E") (:CZ "49 45 N" "15 30 E") + (:FI "64 00 N" "26 00 E") (:FJ "18 00 S" "175 00 E") (:FK "51 45 S" "59 00 W") + (:FM "6 55 N" "158 15 E") (:FO "62 00 N" "7 00 W") (:PF "15 00 S" "140 00 W") + (:FR "46 00 N" "2 00 E") (:GM "13 28 N" "16 34 W") (:GA "1 00 S" "11 45 E") + (:GE "42 00 N" "43 30 E") (:GH "8 00 N" "2 00 W") (:GI "36 08 N" "5 21 W") + (:GD "12 07 N" "61 40 W") (:GG "49 28 N" "2 35 W") (:GL "72 00 N" "40 00 W") + (:DE "51 00 N" "9 00 E") (:GU "13 28 N" "144 47 E") (:GR "39 00 N" "22 00 E") + (:GT "15 30 N" "90 15 W") (:GN "11 00 N" "10 00 W") (:GY "5 00 N" "59 00 W") + (:PS "31 25 N" "34 20 E") (:HT "19 00 N" "72 25 W") (:HK "22 15 N" "114 10 E") + (:HM "53 06 S" "72 31 E") (:HN "15 00 N" "86 30 W") (:HR "45 10 N" "15 30 E") + (:HU "47 00 N" "20 00 E") (:IS "65 00 N" "18 00 W") (:ID "5 00 S" "120 00 E") + (:IM "54 15 N" "4 30 W") (:IN "20 00 N" "77 00 E") (:IO "6 00 S" "71 30 E") + (:IR "32 00 N" "53 00 E") (:IL "31 30 N" "34 45 E") (:IT "42 50 N" "12 50 E") + (:CI "8 00 N" "5 00 W") (:IQ "33 00 N" "44 00 E") (:JP "36 00 N" "138 00 E") + (:JE "49 15 N" "2 10 W") (:JM "18 15 N" "77 30 W") (:JO "31 00 N" "36 00 E") + (:KE "1 00 N" "38 00 E") (:KG "41 00 N" "75 00 E") (:KP "40 00 N" "127 00 E") + (:KI "1 25 N" "173 00 E") (:KR "37 00 N" "127 30 E") + (:CX "10 30 S" "105 40 E") (:KW "29 30 N" "45 45 E") (:KZ "48 00 N" "68 00 E") + (:LA "18 00 N" "105 00 E") (:LB "33 50 N" "35 50 E") (:LV "57 00 N" "25 00 E") + (:LT "56 00 N" "24 00 E") (:LR "6 30 N" "9 30 W") (:SK "48 40 N" "19 30 E") + (:LI "47 16 N" "9 32 E") (:LS "29 30 S" "28 30 E") (:LU "49 45 N" "6 10 E") + (:LY "25 00 N" "17 00 E") (:MG "20 00 S" "47 00 E") (:MO "22 10 N" "113 33 E") + (:MD "47 00 N" "29 00 E") (:YT "12 50 S" "45 10 E") (:MN "46 00 N" "105 00 E") + (:MS "16 45 N" "62 12 W") (:MW "13 30 S" "34 00 E") (:ME "42 30 N" "19 18 E") + (:MK "41 50 N" "22 00 E") (:ML "17 00 N" "4 00 W") (:MC "43 44 N" "7 24 E") + (:MA "32 00 N" "5 00 W") (:MU "20 17 S" "57 33 E") (:MR "20 00 N" "12 00 W") + (:MT "35 50 N" "14 35 E") (:OM "21 00 N" "57 00 E") (:MV "3 15 N" "73 00 E") + (:MX "23 00 N" "102 00 W") (:MY "2 30 N" "112 30 E") (:MZ "18 15 S" "35 00 E") + (:NC "21 30 S" "165 30 E") (:NU "19 02 S" "169 52 W") + (:NF "29 02 S" "167 57 E") (:NE "16 00 N" "8 00 E") (:VU "16 00 S" "167 00 E") + (:NG "10 00 N" "8 00 E") (:NL "52 30 N" "5 45 E") (:NO "62 00 N" "10 00 E") + (:NP "28 00 N" "84 00 E") (:NR "0 32 S" "166 55 E") (:SR "4 00 N" "56 00 W") + (:AN "12 15 N" "68 45 W") (:NI "13 00 N" "85 00 W") (:NZ "41 00 S" "174 00 E") + (:PY "23 00 S" "58 00 W") (:PN "25 04 S" "130 06 W") (:PE "10 00 S" "76 00 W") + (:PK "30 00 N" "70 00 E") (:PL "52 00 N" "20 00 E") (:PA "9 00 N" "80 00 W") + (:PT "39 30 N" "8 00 W") (:PG "6 00 S" "147 00 E") (:PW "7 30 N" "134 30 E") + (:GW "12 00 N" "15 00 W") (:QA "25 30 N" "51 15 E") (:RS "44 00 N" "21 00 E") + (:MH "9 00 N" "168 00 E") (:MF "18 05 N" "63 57 W") (:RO "46 00 N" "25 00 E") + (:PH "13 00 N" "122 00 E") (:PR "18 15 N" "66 30 W") + (:RU "60 00 N" "100 00 E") (:RW "2 00 S" "30 00 E") (:SA "25 00 N" "45 00 E") + (:PM "46 50 N" "56 20 W") (:KN "17 20 N" "62 45 W") (:SC "4 35 S" "55 40 E") + (:ZA "29 00 S" "24 00 E") (:SN "14 00 N" "14 00 W") (:SI "46 07 N" "14 49 E") + (:SL "8 30 N" "11 30 W") (:SM "43 46 N" "12 25 E") (:SG "1 22 N" "103 48 E") + (:SO "10 00 N" "49 00 E") (:ES "40 00 N" "4 00 W") (:LC "13 53 N" "60 58 W") + (:SD "15 00 N" "30 00 E") (:SJ "78 00 N" "20 00 E") (:SE "62 00 N" "15 00 E") + (:GS "54 30 S" "37 00 W") (:SY "35 00 N" "38 00 E") (:CH "47 00 N" "8 00 E") + (:BL "17 90 N" "62 85 W") (:TT "11 00 N" "61 00 W") (:TH "15 00 N" "100 00 E") + (:TJ "39 00 N" "71 00 E") (:TC "21 45 N" "71 35 W") (:TK "9 00 S" "172 00 W") + (:TO "20 00 S" "175 00 W") (:TG "8 00 N" "1 10 E") (:ST "1 00 N" "7 00 E") + (:TN "34 00 N" "9 00 E") (:TL "8 50 S" "125 55 E") (:TR "39 00 N" "35 00 E") + (:TV "8 00 S" "178 00 E") (:TW "23 30 N" "121 00 E") (:TM "40 00 N" "60 00 E") + (:TZ "6 00 S" "35 00 E") (:UG "1 00 N" "32 00 E") (:GB "54 00 N" "2 00 W") + (:UA "49 00 N" "32 00 E") (:US "38 00 N" "97 00 W") (:BF "13 00 N" "2 00 W") + (:UY "33 00 S" "56 00 W") (:UZ "41 00 N" "64 00 E") (:VC "13 15 N" "61 12 W") + (:VE "8 00 N" "66 00 W") (:VG "18 30 N" "64 30 W") (:VN "16 00 N" "106 00 E") + (:VI "18 20 N" "64 50 W") (:VA "41 54 N" "12 27 E") (:NA "22 00 S" "17 00 E") + (:PS "32 00 N" "35 15 E") (:WF "13 18 S" "176 12 W") (:EH "24 30 N" "13 00 W") + (:WS "13 35 S" "172 20 W") (:SZ "26 30 S" "31 30 E") (:YE "15 00 N" "48 00 E"))))) (defvar *country-english-names* '((:AD "Andorra") (:AE "United Arab Emirates") (:AF "Afghanistan")

1 0

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

29 Jul '08

Revision: 3675 Author: ksprotte URL: http://bknr.net/trac/changeset/3675 factored slot-strings into a seperate file U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/poi.lisp A trunk/projects/bos/m2/slot-strings.lisp Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-29 09:59:45 UTC (rev 3674) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-29 10:06:05 UTC (rev 3675) @@ -11,7 +11,7 @@ (:file "geometry" :depends-on ("packages")) (:file "config" :depends-on ("packages")) (:file "utils" :depends-on ("packages")) - (:file "news" :depends-on ("packages" "poi")) + (:file "news" :depends-on ("packages" "slot-strings")) (:file "tiled-index" :depends-on ("packages")) (:file "mail-generator" :depends-on ("packages")) (:file "make-certificate" :depends-on ("packages")) @@ -24,7 +24,8 @@ (:file "allocation" :depends-on ("geometry" "packages")) (:file "allocation-cache" :depends-on ("allocation" "initialization-subsystem" "packages" "utils")) - (:file "poi" :depends-on ("packages")) + (:file "slot-strings" :depends-on ("packages")) + (:file "poi" :depends-on ("packages" "slot-strings")) (:file "import" :depends-on ("packages")) (:file "map" :depends-on ("config" "packages" "tiled-index")) (:file "export" :depends-on ("packages")) Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 09:59:45 UTC (rev 3674) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 10:06:05 UTC (rev 3675) @@ -3,34 +3,8 @@ ;; Klassen und Funktione für die "Points of Information", die für die ;; Quadratmeter-Datenbank gespeichert werden. -;; Die Implementation kurvt ein bisschen um den aktuellen Datastore -;; herum, da eine ästhetische Implementation der mehrsprachigen -;; Strings MOP erforderlich machen würde, die Umstellung des Datastore -;; auf MOP jedoch noch nicht fertig ist. - (in-package :bos.m2) -;; Multilinguale Strings als Slots, werden als Hashes im Objekt -;; gespeichert und über slot-string bzw. (setf slot-string) -;; angesprochen. - -(defun make-string-hash-table () - (make-hash-table :test #'equal)) - -(defun slot-string (object slot-name language &optional (not-found-value "")) - (or (gethash language (slot-value object slot-name)) not-found-value)) - -(defun set-slot-string (object slot-name language new-value) - (unless (in-transaction-p) - (error "attempt to set string in multi-language string slot ~a of object ~a outside of transaction" slot-name object)) - (setf (gethash language (slot-value object slot-name)) new-value)) - -(defsetf slot-string set-slot-string) - -(deftransaction set-slot-string-values (object language &rest args) - (loop for (slot-name value) on args by #'cddr - do (setf (slot-string object slot-name language) value))) - ;;; POI-Anwendungsklassen und Konstruktoren ;;; poi-image @@ -75,19 +49,16 @@ ;;; poi (define-persistent-class poi () - ((name :read :index-type string-unique-index + ((published :update :initform nil) + (name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") (title :update :initform (make-string-hash-table) :documentation "Angezeigter Name") (subtitle :update :initform (make-string-hash-table) :documentation "Unterschrift") (description :update :initform (make-string-hash-table) :documentation "Beschreibungstext") (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") - (icon :update :initform "palme" :documentation "Name des Icons") - (images :update :initform nil) - (airals :update :initform nil) - (panoramas :update :initform nil) - (movies :update :initform nil) - (published :update :initform nil))) + (icon :update :initform "palme" :documentation "Name des Icons") + (medias :update :initform nil))) (defmethod poi-movies :before ((poi poi)) "Lazily update the db schema. Method can be removed later." Added: trunk/projects/bos/m2/slot-strings.lisp =================================================================== --- trunk/projects/bos/m2/slot-strings.lisp (rev 0) +++ trunk/projects/bos/m2/slot-strings.lisp 2008-07-29 10:06:05 UTC (rev 3675) @@ -0,0 +1,28 @@ +(in-package :bos.m2) + +;; Die Implementation kurvt ein bisschen um den aktuellen Datastore +;; herum, da eine ästhetische Implementation der mehrsprachigen +;; Strings MOP erforderlich machen würde, die Umstellung des Datastore +;; auf MOP jedoch noch nicht fertig ist. + +;; Multilinguale Strings als Slots, werden als Hashes im Objekt +;; gespeichert und über slot-string bzw. (setf slot-string) +;; angesprochen. + +(defun make-string-hash-table () + (make-hash-table :test #'equal)) + +(defun slot-string (object slot-name language &optional (not-found-value "")) + (or (gethash language (slot-value object slot-name)) not-found-value)) + +(defun set-slot-string (object slot-name language new-value) + (unless (in-transaction-p) + (error "attempt to set string in multi-language string slot ~a of object ~a outside of transaction" slot-name object)) + (setf (gethash language (slot-value object slot-name)) new-value)) + +(defsetf slot-string set-slot-string) + +(deftransaction set-slot-string-values (object language &rest args) + (loop for (slot-name value) on args by #'cddr + do (setf (slot-string object slot-name language) value))) +

1 0

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

29 Jul '08

Revision: 3674 Author: hans URL: http://bknr.net/trac/changeset/3674 Export slot value conversion function U trunk/bknr/datastore/src/data/package.lisp Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-07-29 08:56:38 UTC (rev 3673) +++ trunk/bknr/datastore/src/data/package.lisp 2008-07-29 09:59:45 UTC (rev 3674) @@ -71,6 +71,8 @@ #:store-object-remove-keywords #:store-object-set-keywords + #:convert-slot-value-while-restoring + #:persistent-change-class #:map-class-instances

1 0