[bknr-cvs] r1978 - in branches/xml-class-rework: bknr/src/rss projects/bos/m2 projects/bos/worldpay-test
bknr at bknr.net
bknr at bknr.net
Sun Aug 13 13:31:53 UTC 2006
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"))
More information about the Bknr-cvs
mailing list