+ | +|||
+ | +
+ Schaffen Sie Regenwald!
+ + |
+ + | +|
+ | ++ + + Spenden Sie! + + | ++ | +|
+ + + + | +|||
+ |
+ Satellitenkarte
+ |
+ + | |
+ | + + + Es dreht sich um m?. + + | ++ | |
+ + + + | +
From bknr at bknr.net Sun Aug 13 09:48:06 2006
From: bknr at bknr.net (bknr at bknr.net)
Date: Sun, 13 Aug 2006 05:48:06 -0400 (EDT)
Subject: [bknr-cvs] r1976 - in branches/xml-class-rework/bknr/src: . rss web
Message-ID: <20060813094806.B54F89@common-lisp.net>
Author: hhubner
Date: 2006-08-13 05:48:06 -0400 (Sun, 13 Aug 2006)
New Revision: 1976
Modified:
branches/xml-class-rework/bknr/src/packages.lisp
branches/xml-class-rework/bknr/src/rss/rss.lisp
branches/xml-class-rework/bknr/src/web/handlers.lisp
Log:
Reworked RSS generation.
Modified: branches/xml-class-rework/bknr/src/packages.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/packages.lisp 2006-07-23 16:07:35 UTC (rev 1975)
+++ branches/xml-class-rework/bknr/src/packages.lisp 2006-08-13 09:48:06 UTC (rev 1976)
@@ -61,6 +61,8 @@
;; item
#:rss-item
#:rss-item-channel
+ #:rss-item-published
+ #:rss-item-pub-date
#:rss-item-title
#:rss-item-link
#:rss-item-description
Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-23 16:07:35 UTC (rev 1975)
+++ branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-08-13 09:48:06 UTC (rev 1976)
@@ -47,14 +47,22 @@
(link :update)
(description :update)
(last-update :update :initform (get-universal-time))
- (max-item-age :update :initform (* 7 3600))
+ (max-item-age :update :initform (* 4 7 3600))
(items :update :initform nil)))
;; Mixin for items
(define-persistent-class rss-item ()
- ((pub-date :read)))
+ ())
+(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))
@@ -73,7 +81,7 @@
(dolist (slot '(title link description))
(render-mandatory-element channel slot))
- (dolist (item (rss-channel-items channel))
+ (dolist (item (remove-if-not #'rss-item-published (rss-channel-items channel)))
(rss-item-xml item))))))
(defmethod rss-channel-items ((channel rss-channel))
@@ -118,6 +126,9 @@
(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)))
Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-07-23 16:07:35 UTC (rev 1975)
+++ branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-08-13 09:48:06 UTC (rev 1976)
@@ -231,11 +231,13 @@
(setf (session-variable :login-redirect-uri)
(redirect-uri (request-uri req)))
(redirect (website-make-path *website* "login") req))
- (handler-bind ((error #'(lambda (e)
- (funcall (website-show-error-page-function *website*) e)
- (do-error-log-request req e)
- (error e))))
- (handle handler req)))
+ (if (member :notrap net.aserve::*debug-current* :test #'eq)
+ (handle handler req)
+ (handler-bind ((error #'(lambda (e)
+ (funcall (website-show-error-page-function *website*) e)
+ (do-error-log-request req e)
+ (error e))))
+ (handle handler req))))
(handler-case
(mapcar #'delete-file (mapcar #'cdr (request-uploaded-files req)))
(error (e)
From bknr at bknr.net Sun Aug 13 09:52:37 2006
From: bknr at bknr.net (bknr at bknr.net)
Date: Sun, 13 Aug 2006 05:52:37 -0400 (EDT)
Subject: [bknr-cvs] r1977 - in branches/xml-class-rework: modules/text
modules/url projects/bos projects/bos/m2
projects/bos/payment-website/templates/de
projects/bos/worldpay-test thirdparty/portableaserve/aserve
Message-ID: <20060813095237.E0D23108A@common-lisp.net>
Author: hhubner
Date: 2006-08-13 05:52:35 -0400 (Sun, 13 Aug 2006)
New Revision: 1977
Added:
branches/xml-class-rework/projects/bos/payment-website/templates/de/news-extern.xml
branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel_news.xml
branches/xml-class-rework/projects/bos/worldpay-test/news-rss.lisp
Modified:
branches/xml-class-rework/modules/text/blog-handlers.lisp
branches/xml-class-rework/modules/url/url-handlers.lisp
branches/xml-class-rework/projects/bos/build.sh
branches/xml-class-rework/projects/bos/m2/m2.lisp
branches/xml-class-rework/projects/bos/m2/news.lisp
branches/xml-class-rework/projects/bos/m2/packages.lisp
branches/xml-class-rework/projects/bos/payment-website/templates/de/quittung.xml
branches/xml-class-rework/projects/bos/payment-website/templates/de/sponsor_canceled.xml
branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel.xml
branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel_main.xml
branches/xml-class-rework/projects/bos/payment-website/templates/de/versand_geschenk.xml
branches/xml-class-rework/projects/bos/payment-website/templates/de/versand_info.xml
branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
branches/xml-class-rework/thirdparty/portableaserve/aserve/main.cl
Log:
Add RSS feed for news items
Modified: branches/xml-class-rework/modules/text/blog-handlers.lisp
===================================================================
--- branches/xml-class-rework/modules/text/blog-handlers.lisp 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/modules/text/blog-handlers.lisp 2006-08-13 09:52:35 UTC (rev 1977)
@@ -50,31 +50,6 @@
(blog-page blog grouped-articles
:start-date (object-date-list-handler-date handler blog req)))))
-(defclass rss-blog-handler (object-rss-handler blog-handler)
- ())
-
-(defmethod create-object-rss-feed ((handler rss-blog-handler) blog req)
- (if blog
- (let* ((site-url (website-url (page-handler-site handler)))
- (url (puri:merge-uris (parse-uri (blog-name blog))
- (page-handler-url handler)))
- (blog-items (mapcar #'(lambda (article)
- (article-to-rss-item article :url site-url))
- (subseq (sort (blog-articles blog)
- #'> :key #'article-time)
- 0 20))))
- (make-instance 'rss-feed
- :channel
- (make-instance 'rss-channel
- :about (render-uri url nil)
- :title (blog-name blog)
- :link (render-uri url nil)
- :items (mapcar #'rss-item-link blog-items))
- :items blog-items))
- (make-instance 'rss-feed :channel (make-instance 'rss-channel
- :about "no such blog"
- :title "no such blog"))))
-
(defclass search-blog-handler (edit-object-handler blog-handler)
())
Modified: branches/xml-class-rework/modules/url/url-handlers.lisp
===================================================================
--- branches/xml-class-rework/modules/url/url-handlers.lisp 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/modules/url/url-handlers.lisp 2006-08-13 09:52:35 UTC (rev 1977)
@@ -157,42 +157,3 @@
(format nil "/url-intersection-rss/~A"
(parse-url req)))
-;;; rss url feeds
-(defclass rss-url-handler (object-rss-handler url-page-handler)
- ())
-
-(defmethod create-object-rss-feed ((handler rss-url-handler)
- object req)
- (let* ((site-url (website-url (page-handler-site handler)))
- (url-items (mapcar #'url-submission-to-rss-item
- (subseq (sort (object-list-handler-get-objects
- handler object req)
- #'> :key #'url-submission-date)
- 0 30))))
- (if url-items
- (make-instance 'rss-feed
- :channel (make-instance
- 'rss-channel
- :about (render-uri site-url nil)
- :title (object-list-handler-title
- handler object req)
- :link (render-uri site-url nil)
- :items (mapcar #'rss-item-link url-items))
- :items url-items)
- (make-instance 'rss-feed
- :channel (make-instance 'rss-channel
- :about "no such keyword"
- :title "no such keyword")))))
-
-(defclass rss-url-keyword-handler (rss-url-handler url-keyword-handler)
- ())
-
-(defclass rss-url-union-handler (rss-url-handler url-union-handler)
- ())
-
-(defclass rss-url-intersection-handler (rss-url-handler url-intersection-handler)
- ())
-
-(defclass rss-url-submitter-handler (rss-url-handler url-submitter-handler)
- ())
-
Modified: branches/xml-class-rework/projects/bos/build.sh
===================================================================
--- branches/xml-class-rework/projects/bos/build.sh 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/projects/bos/build.sh 2006-08-13 09:52:35 UTC (rev 1977)
@@ -1,20 +1,5 @@
#!/bin/sh -e
-case "$1" in
- --clean)
- echo "deleting fasls... (use --fast to suppress)"
- find .. -name \*.x86f -print0 | xargs -0 rm
- ;;
- --fast)
- echo "not deleting fasls"
- ;;
- *)
- echo "error: expected argument --clean or --fast" 1>&2
- exit 1
- ;;
-esac
-
-pwd
set -x
(cd ../thirdparty/cl-gd && make)
lisp -core cmucl.core -noinit -load load.lisp -load build.lisp
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-08-13 09:52:35 UTC (rev 1977)
@@ -40,7 +40,8 @@
(define-persistent-class m2 ()
((x :read)
(y :read)
- (contract :update :relaxed-object-reference t))
+ (contract :update :relaxed-object-reference t)
+ (my-slot :read))
(:default-initargs :contract nil)
(:class-indices (m2-index :index-type tiled-index
:slots (x y)
Modified: branches/xml-class-rework/projects/bos/m2/news.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/news.lisp 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/projects/bos/m2/news.lisp 2006-08-13 09:52:35 UTC (rev 1977)
@@ -4,7 +4,7 @@
(in-package :bos.m2)
-(define-persistent-class news-item ()
+(define-persistent-class news-item (rss-item)
((time :read :initform (get-universal-time))
(title :none :initform (make-string-hash-table))
(text :none :initform (make-string-hash-table))))
@@ -27,9 +27,13 @@
(defmethod news-item-text ((news-item news-item) language)
(slot-string news-item 'text language))
+(defun news-item-published (item language)
+ (and (slot-string item 'title language nil)
+ (slot-string item 'text language nil)))
+
(defun all-news-items (&optional language)
(if language
- (remove-if (complement #'(lambda (news-item) (and (slot-string news-item 'title language nil)
- (slot-string news-item 'text language nil))))
- (store-objects-with-class 'news-item))
- (sort (copy-list (store-objects-with-class 'news-item)) #'> :key #'news-item-time)))
\ No newline at end of file
+ (remove-if-not (lambda (item) (news-item-published item language))
+ (store-objects-with-class 'news-item))
+ (sort (copy-list (store-objects-with-class 'news-item)) #'> :key #'news-item-time)))
+
Modified: branches/xml-class-rework/projects/bos/m2/packages.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-08-13 09:52:35 UTC (rev 1977)
@@ -34,8 +34,10 @@
:bknr.web
:bknr.images
:bknr.statistics
+ :bknr.rss
:bos.m2.config
:net.post-office
+ :cxml
:cl-gd)
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
(:export #:m2-store
Added: branches/xml-class-rework/projects/bos/payment-website/templates/de/news-extern.xml
===================================================================
--- branches/xml-class-rework/projects/bos/payment-website/templates/de/news-extern.xml 2006-08-13 09:48:06 UTC (rev 1976)
+++ branches/xml-class-rework/projects/bos/payment-website/templates/de/news-extern.xml 2006-08-13 09:52:35 UTC (rev 1977)
@@ -0,0 +1,29 @@
+
+
+