Author: hhubner Date: 2006-08-13 09:31:52 -0400 (Sun, 13 Aug 2006) New Revision: 1978 Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp branches/xml-class-rework/projects/bos/m2/m2.lisp branches/xml-class-rework/projects/bos/worldpay-test/news-rss.lisp branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd Log: Remove the requirement to derive RSS item classes from rss-item. Make contracts into RSS items. Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-08-13 09:52:35 UTC (rev 1977) +++ branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-08-13 13:31:52 UTC (rev 1978) @@ -57,12 +57,6 @@ (defgeneric rss-item-pub-date (item)) -(defmethod rss-item-pub-date ((item rss-item)) - "The default implementation for the publication date delivers the -current system date/time as publication date." - (warn "no rss-item-pub-date defined for class ~A, using current date/time" (class-of item)) - (get-universal-time)) - (defun make-rss-channel (name title description link &rest args) (apply #'make-object 'rss-channel :name name :title title :description description :link link args)) @@ -96,57 +90,42 @@ ;; Internal helper functions to find a channel -(defmethod remove-item ((channel rss-channel) (item rss-item)) +(defmethod remove-item ((channel rss-channel) item) "Remove item from channel. May only be called within transaction context." (setf (slot-value channel 'items) (remove item (rss-channel-items channel)))) -(defmethod remove-item ((channel string) (item rss-item)) +(defmethod remove-item ((channel string) item) (aif (find-rss-channel channel) (remove-item it item))) -(defmethod remove-item ((channel (eql nil)) (item rss-item)) +(defmethod remove-item ((channel (eql nil)) item) (warn "no RSS channel defined for item ~A" item)) -(defmethod add-item ((channel rss-channel) (item rss-item)) +(defmethod add-item ((channel rss-channel) item) "Add item to channel. May only be called within transaction context." (setf (slot-value channel 'items) (cons item (rss-channel-items channel)))) -(defmethod add-item ((channel string) (item rss-item)) +(defmethod add-item ((channel string) item) (aif (find-rss-channel channel) (add-item it item) (warn "can't find RSS channel ~A to add newly created item ~A to" channel item))) -(defmethod add-item ((channel (eql nil)) (item rss-item)) +(defmethod add-item ((channel (eql nil)) item) (warn "no RSS channel defined for item ~A" item)) (defmethod initialize-persistent-instance :after ((rss-item rss-item)) - (setf (slot-value rss-item 'pub-date) (get-universal-time)) (add-item (rss-item-channel rss-item) rss-item)) (defmethod destroy-object :before ((rss-item rss-item)) (remove-item (rss-item-channel rss-item) rss-item)) -(defmethod rss-item-published ((rss-item rss-item)) - t) - -(defmethod rss-item-channel ((rss-item rss-item))) -(defmethod rss-item-title ((rss-item rss-item))) -(defmethod rss-item-link ((rss-item rss-item))) -(defmethod rss-item-description ((rss-item rss-item))) -(defmethod rss-item-author ((rss-item rss-item))) -(defmethod rss-item-category ((rss-item rss-item))) -(defmethod rss-item-comments ((rss-item rss-item))) -(defmethod rss-item-enclosure ((rss-item rss-item))) -(defmethod rss-item-guid ((rss-item rss-item))) -(defmethod rss-item-source ((rss-item rss-item))) - (defun item-slot-element (item slot-name) (let ((accessor (kmrcl:concat-symbol-pkg (find-package :bknr.rss) 'rss-item- slot-name))) (aif (funcall accessor item) (with-element (string-downcase (symbol-name slot-name)) (text it))))) -(defmethod rss-item-xml ((item rss-item)) +(defun rss-item-xml (item) (with-element "item" (dolist (slot '(title link author category comments enclosure source)) (item-slot-element item slot)) @@ -159,3 +138,27 @@ (cdata it))) (with-element "pubDate" (text (format-date-time (rss-item-pub-date item) :mail-style t))))) + +;; All items present on an RSS stream can implement the access +;; methods below. + +(defmethod rss-item-published (item) + t) + +(defmethod rss-item-pub-date (item) + "The default implementation for the publication date delivers the +current system date/time as publication date." + (warn "no rss-item-pub-date defined for class ~A, using current date/time" (class-of item)) + (get-universal-time)) + +(defmethod rss-item-channel (item)) +(defmethod rss-item-title (item)) +(defmethod rss-item-link (item)) +(defmethod rss-item-description (item)) +(defmethod rss-item-author (item)) +(defmethod rss-item-category (item)) +(defmethod rss-item-comments (item)) +(defmethod rss-item-enclosure (item)) +(defmethod rss-item-guid (item)) +(defmethod rss-item-source (item)) + Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-08-13 09:52:35 UTC (rev 1977) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-08-13 13:31:52 UTC (rev 1978) @@ -273,13 +273,15 @@ (deftransaction do-make-contract (sponsor m2-count &key date paidp expires download-only) (let ((m2s (find-free-m2s m2-count))) (if m2s - (make-object 'contract - :sponsor sponsor - :date date - :paidp paidp - :m2s m2s - :expires expires - :download-only download-only) + (let ((contract (make-object 'contract + :sponsor sponsor + :date date + :paidp paidp + :m2s m2s + :expires expires + :download-only download-only))) + (bknr.rss::add-item "news" contract) + contract) (warn "can't create contract, ~A square meters for ~A could not be allocated" m2-count sponsor)))) (defun make-contract (sponsor m2-count Modified: branches/xml-class-rework/projects/bos/worldpay-test/news-rss.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/news-rss.lisp 2006-08-13 09:52:35 UTC (rev 1977) +++ branches/xml-class-rework/projects/bos/worldpay-test/news-rss.lisp 2006-08-13 13:31:52 UTC (rev 1978) @@ -4,8 +4,7 @@ "news") (defmethod rss-item-published ((item news-item)) - (format t "Language: ~A~%" (worldpay-test::current-website-language)) - t) + (news-item-published item (worldpay-test::current-website-language))) (defmethod rss-item-title ((item news-item)) (news-item-title item (worldpay-test::current-website-language))) Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-08-13 09:52:35 UTC (rev 1977) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-08-13 13:31:52 UTC (rev 1978) @@ -35,6 +35,7 @@ (:file "tags" :depends-on ("web-utils")) (:file "news-tags" :depends-on ("web-utils")) (:file "news-rss" :depends-on ("web-utils")) + (:file "contract-rss" :depends-on ("web-utils")) (:file "worldpay-test" :depends-on ("news-tags" "tags" "map-handlers" "map-browser-handler" "poi-handlers" "boi-handlers" "contract-handlers" "sponsor-handlers" "news-handlers" "allocation-area-handlers"))