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 @@ + + + + +
+
+ +
+
+
+
+
+ + Infos direkt nach Hause?

+ Ihre E-Mail-Adresse: +

+ + +
+
+
+
Modified: branches/xml-class-rework/projects/bos/payment-website/templates/de/quittung.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/de/quittung.xml 2006-08-13 09:48:06 UTC (rev 1976) +++ branches/xml-class-rework/projects/bos/payment-website/templates/de/quittung.xml 2006-08-13 09:52:35 UTC (rev 1977) @@ -23,7 +23,7 @@ Modified: branches/xml-class-rework/projects/bos/payment-website/templates/de/sponsor_canceled.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/de/sponsor_canceled.xml 2006-08-13 09:48:06 UTC (rev 1976) +++ branches/xml-class-rework/projects/bos/payment-website/templates/de/sponsor_canceled.xml 2006-08-13 09:52:35 UTC (rev 1977) @@ -23,7 +23,7 @@ Modified: branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel.xml 2006-08-13 09:48:06 UTC (rev 1976) +++ branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel.xml 2006-08-13 09:52:35 UTC (rev 1977) @@ -21,7 +21,7 @@ Modified: branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel_main.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel_main.xml 2006-08-13 09:48:06 UTC (rev 1976) +++ branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel_main.xml 2006-08-13 09:52:35 UTC (rev 1977) @@ -9,6 +9,8 @@ + @@ -19,8 +21,8 @@