mailman3.common-lisp.net
Sign In
Sign Up
Sign In
Sign Up
Manage this list
×
Keyboard Shortcuts
Thread View
j
: Next unread message
k
: Previous unread message
j a
: Jump to all threads
j l
: Jump to MailingList overview
2025
January
2024
December
November
October
September
August
July
June
May
April
March
February
January
2023
December
November
October
September
August
July
June
May
April
March
February
January
2022
December
November
October
September
August
July
June
May
April
March
February
January
2021
December
November
October
September
August
July
June
May
April
March
February
January
2020
December
November
October
September
August
July
June
May
April
March
February
January
2019
December
November
October
September
August
July
June
May
April
March
February
January
2018
December
November
October
September
August
July
June
May
April
March
February
January
2017
December
November
October
September
August
July
June
May
April
March
February
January
2016
December
November
October
September
August
July
June
May
April
March
February
January
2015
December
November
October
September
August
July
June
May
April
March
February
January
2014
December
November
October
September
August
July
June
May
April
March
February
January
2013
December
November
October
September
August
July
June
May
April
March
February
January
2012
December
November
October
September
August
July
June
May
April
March
February
January
2011
December
November
October
September
August
July
June
May
April
March
February
January
2010
December
November
October
September
August
July
June
May
April
March
February
January
2009
December
November
October
September
August
July
June
May
April
March
February
January
2008
December
November
October
September
August
July
June
May
April
March
February
January
2007
December
November
October
September
August
July
June
May
April
March
February
January
2006
December
November
October
September
August
July
June
May
April
March
February
January
List overview
Download
bknr-cvs
July 2006
----- 2025 -----
January 2025
----- 2024 -----
December 2024
November 2024
October 2024
September 2024
August 2024
July 2024
June 2024
May 2024
April 2024
March 2024
February 2024
January 2024
----- 2023 -----
December 2023
November 2023
October 2023
September 2023
August 2023
July 2023
June 2023
May 2023
April 2023
March 2023
February 2023
January 2023
----- 2022 -----
December 2022
November 2022
October 2022
September 2022
August 2022
July 2022
June 2022
May 2022
April 2022
March 2022
February 2022
January 2022
----- 2021 -----
December 2021
November 2021
October 2021
September 2021
August 2021
July 2021
June 2021
May 2021
April 2021
March 2021
February 2021
January 2021
----- 2020 -----
December 2020
November 2020
October 2020
September 2020
August 2020
July 2020
June 2020
May 2020
April 2020
March 2020
February 2020
January 2020
----- 2019 -----
December 2019
November 2019
October 2019
September 2019
August 2019
July 2019
June 2019
May 2019
April 2019
March 2019
February 2019
January 2019
----- 2018 -----
December 2018
November 2018
October 2018
September 2018
August 2018
July 2018
June 2018
May 2018
April 2018
March 2018
February 2018
January 2018
----- 2017 -----
December 2017
November 2017
October 2017
September 2017
August 2017
July 2017
June 2017
May 2017
April 2017
March 2017
February 2017
January 2017
----- 2016 -----
December 2016
November 2016
October 2016
September 2016
August 2016
July 2016
June 2016
May 2016
April 2016
March 2016
February 2016
January 2016
----- 2015 -----
December 2015
November 2015
October 2015
September 2015
August 2015
July 2015
June 2015
May 2015
April 2015
March 2015
February 2015
January 2015
----- 2014 -----
December 2014
November 2014
October 2014
September 2014
August 2014
July 2014
June 2014
May 2014
April 2014
March 2014
February 2014
January 2014
----- 2013 -----
December 2013
November 2013
October 2013
September 2013
August 2013
July 2013
June 2013
May 2013
April 2013
March 2013
February 2013
January 2013
----- 2012 -----
December 2012
November 2012
October 2012
September 2012
August 2012
July 2012
June 2012
May 2012
April 2012
March 2012
February 2012
January 2012
----- 2011 -----
December 2011
November 2011
October 2011
September 2011
August 2011
July 2011
June 2011
May 2011
April 2011
March 2011
February 2011
January 2011
----- 2010 -----
December 2010
November 2010
October 2010
September 2010
August 2010
July 2010
June 2010
May 2010
April 2010
March 2010
February 2010
January 2010
----- 2009 -----
December 2009
November 2009
October 2009
September 2009
August 2009
July 2009
June 2009
May 2009
April 2009
March 2009
February 2009
January 2009
----- 2008 -----
December 2008
November 2008
October 2008
September 2008
August 2008
July 2008
June 2008
May 2008
April 2008
March 2008
February 2008
January 2008
----- 2007 -----
December 2007
November 2007
October 2007
September 2007
August 2007
July 2007
June 2007
May 2007
April 2007
March 2007
February 2007
January 2007
----- 2006 -----
December 2006
November 2006
October 2006
September 2006
August 2006
July 2006
June 2006
May 2006
April 2006
March 2006
February 2006
January 2006
bknr-cvs@common-lisp.net
1 participants
15 discussions
Start a n
N
ew thread
[bknr-cvs] r1975 - in branches/xml-class-rework/projects/quickhoney: src website/static
by bknr@bknr.net
23 Jul '06
23 Jul '06
Author: hhubner Date: 2006-07-23 12:07:35 -0400 (Sun, 23 Jul 2006) New Revision: 1975 Modified: branches/xml-class-rework/projects/quickhoney/src/image.lisp branches/xml-class-rework/projects/quickhoney/website/static/javascript.js Log: Add deep link support for RSS Modified: branches/xml-class-rework/projects/quickhoney/src/image.lisp =================================================================== --- branches/xml-class-rework/projects/quickhoney/src/image.lisp 2006-07-23 16:07:05
…
[View More]
UTC (rev 1974) +++ branches/xml-class-rework/projects/quickhoney/src/image.lisp 2006-07-23 16:07:35 UTC (rev 1975) @@ -20,12 +20,6 @@ (store-object-remove-keywords image 'bknr.web::keywords '(:import))) (get-keywords-intersection-store-images '(:import)))) -(define-persistent-class quickhoney-animation-image (quickhoney-image) - ((animation :update))) - -(defmethod destroy-object :before ((image quickhoney-animation-image)) - (delete-object (quickhoney-animation-image-animation image))) - (defmethod rss-item-channel ((item quickhoney-image)) "quickhoney") @@ -36,4 +30,24 @@ (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image))) (defmethod rss-item-link ((image quickhoney-image)) - (format nil "
http://quickhoney.com/image/~A
" (store-image-name image))) \ No newline at end of file + (make-image-link image)) + +(defmethod rss-item-guid ((image quickhoney-image)) + (make-image-link image)) + +(defmethod quickhoney-image-category ((image quickhoney-image)) + (first (intersection (store-image-keywords image) '(:pixel :vector :photo :contact)))) + +(defmethod quickhoney-image-subcategory ((image quickhoney-image)) + (first (set-difference (store-image-keywords image) '(:pixel :vector :photo :button :contact :published :upload)))) + +(defmethod make-image-link ((image quickhoney-image)) + (format nil "
http://quickhoney.com/index?jumpto=~(~A/~A~)/~A
" + (quickhoney-image-category image) (quickhoney-image-subcategory image) (store-image-name image))) + +(define-persistent-class quickhoney-animation-image (quickhoney-image) + ((animation :update))) + +(defmethod destroy-object :before ((image quickhoney-animation-image)) + (delete-object (quickhoney-animation-image-animation image))) + Modified: branches/xml-class-rework/projects/quickhoney/website/static/javascript.js =================================================================== --- branches/xml-class-rework/projects/quickhoney/website/static/javascript.js 2006-07-23 16:07:05 UTC (rev 1974) +++ branches/xml-class-rework/projects/quickhoney/website/static/javascript.js 2006-07-23 16:07:35 UTC (rev 1975) @@ -231,7 +231,20 @@ document.getElementById("browse").style.visibility = 'hidden'; document.getElementById("results").style.visibility = 'visible'; - display_thumbnail_page(); + if (document.show_picture) { + debug('directly jump to ' + document.show_picture); + for (var i = 0; i < query_result.length; i++) { + debug('got: ' + query_result[i].name + ' want ' + document.show_picture); + if (query_result[i].name == document.show_picture) { + debug('name: ' + query_result[i].name); + display_image(i); + break; + } + } + document.show_picture = null; + } else { + display_thumbnail_page(); + } display_path(); } @@ -589,6 +602,14 @@ document.getElementById("contactimage").src = button_images['contact/contact']; } + + if (document.jump_to) { + var components = document.jump_to.split("/"); + document.jump_to = null; + show_page(components[0]); + subdirectory(components[1]); + document.show_picture = components[2]; + } } function load_button_images() { @@ -1017,6 +1038,12 @@ show_cms_window("login_form"); } + if (document.location.href.indexOf("jumpto=") != -1) { + var jump_to = document.location.href.replace(/.*jumpto=/, ""); + jump_to = jump_to.replace(/[&#].*/, ""); + document.jump_to = jump_to; + } + buttons = document.getElementById("directory").getElementsByTagName('img'); button_links = document.getElementById("directory").getElementsByTagName('a');
[View Less]
1
0
0
0
[bknr-cvs] r1974 - branches/xml-class-rework/projects/quickhoney/website/templates
by bknr@bknr.net
23 Jul '06
23 Jul '06
Author: hhubner Date: 2006-07-23 12:07:05 -0400 (Sun, 23 Jul 2006) New Revision: 1974 Modified: branches/xml-class-rework/projects/quickhoney/website/templates/frontpage.xml Log: Add RSS meta tag to front page Modified: branches/xml-class-rework/projects/quickhoney/website/templates/frontpage.xml =================================================================== --- branches/xml-class-rework/projects/quickhoney/website/templates/frontpage.xml 2006-07-22 13:04:02 UTC (rev 1973) +++
…
[View More]
branches/xml-class-rework/projects/quickhoney/website/templates/frontpage.xml 2006-07-23 16:07:05 UTC (rev 1974) @@ -8,6 +8,8 @@ > <head> <link rel="stylesheet" href="/static/styles.css" /> + <link rel="alternate" type="application/rss+xml" title="RSS Feed" + href="
http://quickhoney.com/rss/quickhoney
" /> <script src="/static/javascript.js" type="text/javascript"><!-- x --> </script> <title>QuickHoney - Nana Rausch + Peter Stemmler</title>
[View Less]
1
0
0
0
[bknr-cvs] r1973 - branches/xml-class-rework/thirdparty/cxml/xml
by bknr@bknr.net
22 Jul '06
22 Jul '06
Author: hhubner Date: 2006-07-22 09:04:02 -0400 (Sat, 22 Jul 2006) New Revision: 1973 Modified: branches/xml-class-rework/thirdparty/cxml/xml/unparse.lisp Log: maybe emit start tag when generating CDATA Modified: branches/xml-class-rework/thirdparty/cxml/xml/unparse.lisp =================================================================== --- branches/xml-class-rework/thirdparty/cxml/xml/unparse.lisp 2006-07-22 13:03:32 UTC (rev 1972) +++ branches/xml-class-rework/thirdparty/cxml/xml/
…
[View More]
unparse.lisp 2006-07-22 13:04:02 UTC (rev 1973) @@ -482,6 +482,7 @@ value) (defun cdata (data) + (maybe-emit-start-tag) (sax:start-cdata *sink*) (sax:characters *sink* (rod data)) (sax:end-cdata *sink*)
[View Less]
1
0
0
0
[bknr-cvs] r1972 - branches/xml-class-rework/bknr/src/rss
by bknr@bknr.net
22 Jul '06
22 Jul '06
Author: hhubner Date: 2006-07-22 09:03:32 -0400 (Sat, 22 Jul 2006) New Revision: 1972 Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp Log: Be more specific about the RSS generated, still not working for GMail clips. Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-22 12:59:15 UTC (rev 1971) +++ branches/xml-class-rework/bknr/src/rss/rss.lisp
…
[View More]
2006-07-22 13:03:32 UTC (rev 1972) @@ -70,7 +70,7 @@ (with-element "rss" (attribute "version" "2.0") (with-element "channel" - (dolist (slot '(title description link)) + (dolist (slot '(title link description)) (render-mandatory-element channel slot)) (dolist (item (rss-channel-items channel)) @@ -137,7 +137,14 @@ (defmethod rss-item-xml ((item rss-item)) (with-element "item" - (dolist (slot '(title link description author category comments enclosure guid source)) + (dolist (slot '(title link author category comments enclosure source)) (item-slot-element item slot)) + (aif (rss-item-guid item) + (with-element "guid" + (attribute "isPermaLink" "true") + (text it))) + (aif (rss-item-description item) + (with-element "description" + (cdata it))) (with-element "pubDate" (text (format-date-time (rss-item-pub-date item) :mail-style t)))))
[View Less]
1
0
0
0
[bknr-cvs] r1971 - in branches/xml-class-rework/bknr/src: . images rss web
by bknr@bknr.net
22 Jul '06
22 Jul '06
Author: hhubner Date: 2006-07-22 08:59:15 -0400 (Sat, 22 Jul 2006) New Revision: 1971 Modified: branches/xml-class-rework/bknr/src/bknr.asd branches/xml-class-rework/bknr/src/images/image-handlers.lisp branches/xml-class-rework/bknr/src/packages.lisp branches/xml-class-rework/bknr/src/rss/rss.lisp branches/xml-class-rework/bknr/src/rss/test.lisp branches/xml-class-rework/bknr/src/web/rss-handlers.lisp Log: Remove old RSS handler code. Modified: branches/xml-class-rework/
…
[View More]
bknr/src/bknr.asd =================================================================== --- branches/xml-class-rework/bknr/src/bknr.asd 2006-07-22 12:58:44 UTC (rev 1970) +++ branches/xml-class-rework/bknr/src/bknr.asd 2006-07-22 12:59:15 UTC (rev 1971) @@ -114,7 +114,7 @@ "templates" "site" "web-utils"))) - :depends-on ("sysclasses" "packages" "xhtmlgen")) + :depends-on ("sysclasses" "packages" "xhtmlgen" "rss")) (:module "images" :components ((:file "image") Modified: branches/xml-class-rework/bknr/src/images/image-handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/images/image-handlers.lisp 2006-07-22 12:58:44 UTC (rev 1970) +++ branches/xml-class-rework/bknr/src/images/image-handlers.lisp 2006-07-22 12:59:15 UTC (rev 1971) @@ -152,6 +152,7 @@ (format nil "/intersection-rss/~A" (parse-url req))) ;;; rss image feeds +#| (defclass rss-image-handler (object-rss-handler image-page-handler) ()) @@ -183,6 +184,7 @@ (defclass rss-image-intersection-handler (rss-image-handler image-intersection-handler) ()) +|# (defclass xml-image-browser-handler (image-handler xml-object-handler) ()) @@ -210,10 +212,12 @@ ("/image-keyword" image-keyword-handler) ("/image-union" image-union-handler) ("/image-intersection" image-intersection-handler) + #| ("/rss-image" rss-image-handler) ("/rss-image-keyword" rss-image-keyword-handler) ("/rss-image-union" rss-image-union-handler) ("/rss-image-intersection" rss-image-intersection-handler) + |# ("/image" imageproc-handler) ("/image-import" image-import-handler) ("/session-image" session-image-handler) Modified: branches/xml-class-rework/bknr/src/packages.lisp =================================================================== --- branches/xml-class-rework/bknr/src/packages.lisp 2006-07-22 12:58:44 UTC (rev 1970) +++ branches/xml-class-rework/bknr/src/packages.lisp 2006-07-22 12:59:15 UTC (rev 1971) @@ -39,6 +39,8 @@ ;; channel #:rss-channel + #:find-rss-channel + #:make-rss-channel #:rss-channel-cleanup #:rss-channel-about #:rss-channel-title @@ -321,7 +323,6 @@ #:keywords-handler #:rss-handler - #:object-rss-handler #:define-bknr-webserver-module Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-22 12:58:44 UTC (rev 1970) +++ branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-22 12:59:15 UTC (rev 1971) @@ -28,11 +28,17 @@ ;; One rss-item can only be in one channel. +;; The channel object has more required elements than the standard +;; specifies in order to make the generated feed documents more widely +;; accepted. + ;;; Paul Graham, On Lisp, p191 (defmacro aif (test-form then-form &optional else-form) `(let ((it ,test-form)) (if it ,then-form ,else-form))) +;; Class for channels + (define-persistent-class rss-channel () ((name :update :index-type string-unique-index @@ -44,6 +50,14 @@ (max-item-age :update :initform (* 7 3600)) (items :update :initform nil))) +;; Mixin for items + +(define-persistent-class rss-item () + ((pub-date :read))) + +(defun make-rss-channel (name title description link &rest args) + (apply #'make-object 'rss-channel :name name :title title :description description :link link args)) + (defun render-mandatory-element (channel element) (with-element (string-downcase (symbol-name element)) (text (aif (and (slot-boundp channel element) @@ -58,6 +72,7 @@ (with-element "channel" (dolist (slot '(title description link)) (render-mandatory-element channel slot)) + (dolist (item (rss-channel-items channel)) (rss-item-xml item)))))) @@ -96,11 +111,6 @@ (defmethod add-item ((channel (eql nil)) (item rss-item)) (warn "no RSS channel defined for item ~A" item)) -;; Mixin for items - -(define-persistent-class rss-item () - ((pub-date :read))) - (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)) @@ -120,7 +130,7 @@ (defmethod rss-item-source ((rss-item rss-item))) (defun item-slot-element (item slot-name) - (let ((accessor (kmrcl:concat-symbol 'rss-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))))) @@ -131,4 +141,3 @@ (item-slot-element item slot)) (with-element "pubDate" (text (format-date-time (rss-item-pub-date item) :mail-style t))))) - Modified: branches/xml-class-rework/bknr/src/rss/test.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/test.lisp 2006-07-22 12:58:44 UTC (rev 1970) +++ branches/xml-class-rework/bknr/src/rss/test.lisp 2006-07-22 12:59:15 UTC (rev 1971) @@ -12,4 +12,6 @@ (defmethod rss-item-author ((item test-item)) "Hans Hübner") -(open-store "/tmp/datastore/") \ No newline at end of file +(open-store "/tmp/datastore/") + +(start :port 8383) \ No newline at end of file Modified: branches/xml-class-rework/bknr/src/web/rss-handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/rss-handlers.lisp 2006-07-22 12:58:44 UTC (rev 1970) +++ branches/xml-class-rework/bknr/src/web/rss-handlers.lisp 2006-07-22 12:59:15 UTC (rev 1971) @@ -1,28 +1,15 @@ (in-package :bknr.web) ;;; rss handlers -(defclass rss-handler (page-handler) - ()) +(defclass rss-handler (object-handler) + () + (:default-initargs :query-function #'bknr.rss:find-rss-channel)) -(defgeneric create-rss-feed (handler req)) +(defmethod handle-object ((handler rss-handler) (channel (eql nil)) req) + (error "invalid channel name")) -(defmethod handle ((handler rss-handler) req) +(defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel) req) (with-bknr-http-response (req :content-type "text/xml") (with-http-body (req *ent*) (html (:princ "<?xml version=\"1.0\"?>") - (write-xml - (bknr.rss:rss-to-xml (create-rss-feed handler req)) - *html-stream* :indent t))))) - -(defclass object-rss-handler (object-handler rss-handler) - ()) - -(defgeneric create-object-rss-feed (handler object req)) - -(defmethod handle-object ((handler object-rss-handler) object req) - (with-bknr-http-response (req :content-type "text/xml") - (with-http-body (req *ent*) - (html (:princ "<?xml version=\"1.0\"?>") - (write-xml - (bknr.rss:rss-to-xml (create-object-rss-feed handler object req)) - *html-stream* :indent t))))) + (bknr.rss:rss-channel-xml channel *html-stream*)))))
[View Less]
1
0
0
0
[bknr-cvs] r1970 - in branches/xml-class-rework/projects/hello-web: . src website/templates
by bknr@bknr.net
22 Jul '06
22 Jul '06
Author: hhubner Date: 2006-07-22 08:58:44 -0400 (Sat, 22 Jul 2006) New Revision: 1970 Added: branches/xml-class-rework/projects/hello-web/src/news.lisp branches/xml-class-rework/projects/hello-web/website/templates/index.xml branches/xml-class-rework/projects/hello-web/website/templates/user-error.xml Removed: branches/xml-class-rework/projects/hello-web/website/templates/index.bknr branches/xml-class-rework/projects/hello-web/website/templates/user-error.bknr Modified:
…
[View More]
branches/xml-class-rework/projects/hello-web/ branches/xml-class-rework/projects/hello-web/src/config.lisp branches/xml-class-rework/projects/hello-web/src/handlers.lisp branches/xml-class-rework/projects/hello-web/src/hello-web.asd branches/xml-class-rework/projects/hello-web/src/init.lisp branches/xml-class-rework/projects/hello-web/src/packages.lisp branches/xml-class-rework/projects/hello-web/src/webserver.lisp Log: Correct file endings of xml files Add RSS feed demo Property changes on: branches/xml-class-rework/projects/hello-web ___________________________________________________________________ Name: svn:ignore + datastore Modified: branches/xml-class-rework/projects/hello-web/src/config.lisp =================================================================== --- branches/xml-class-rework/projects/hello-web/src/config.lisp 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/config.lisp 2006-07-22 12:58:44 UTC (rev 1970) @@ -3,7 +3,7 @@ ;; URL für BASE HREFs (defparameter *website-url* "
http://hello-web.bknr.net
") -(defparameter *root-directory* #p"home:bknr-svn/hello-web/") +(defparameter *root-directory* #p"home:bknr-svn/projects/hello-web/") (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*)) Modified: branches/xml-class-rework/projects/hello-web/src/handlers.lisp =================================================================== --- branches/xml-class-rework/projects/hello-web/src/handlers.lisp 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/handlers.lisp 2006-07-22 12:58:44 UTC (rev 1970) @@ -14,4 +14,5 @@ (with-bknr-page (req :title "demo handler") (html (:p "This is the demo handler, the object id of user " (:b (:princ-safe (first (decoded-handler-path handler req)))) " is " - (:b (:princ-safe (store-object-id object))))))) \ No newline at end of file + (:b (:princ-safe (store-object-id object))))))) + Modified: branches/xml-class-rework/projects/hello-web/src/hello-web.asd =================================================================== --- branches/xml-class-rework/projects/hello-web/src/hello-web.asd 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/hello-web.asd 2006-07-22 12:58:44 UTC (rev 1970) @@ -20,7 +20,6 @@ :cl-ppcre :aserve :cxml - :cl-typesetting :mime :bknr-modules) @@ -30,4 +29,5 @@ (:file "tags" :depends-on ("config")) (:file "handlers" :depends-on ("config")) (:file "webserver" :depends-on ("handlers")) + (:file "news" :depends-on ("config")) (:file "init" :depends-on ("webserver")))) Modified: branches/xml-class-rework/projects/hello-web/src/init.lisp =================================================================== --- branches/xml-class-rework/projects/hello-web/src/init.lisp 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/init.lisp 2006-07-22 12:58:44 UTC (rev 1970) @@ -11,6 +11,7 @@ (unless (find-user "anonymous") (make-user "anonymous") ; used for all anonymous sessions (make-user "admin" :password "admin" :full-name "Administrator" :flags '(:admin)) - (import-image "bknr-logo.png" :keywords '(:banner :bknr))) + (import-image "bknr-logo.png" :keywords '(:banner :bknr)) + (make-rss-channel "default" "BKNR Hello Web" "default RSS channel of the BKNR hello web site" *website-url*)) (publish-hello-web)) Added: branches/xml-class-rework/projects/hello-web/src/news.lisp =================================================================== --- branches/xml-class-rework/projects/hello-web/src/news.lisp 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/news.lisp 2006-07-22 12:58:44 UTC (rev 1970) @@ -0,0 +1,23 @@ +(in-package :hello-web) + +(define-persistent-class news-item (rss-item) + ((title :read) + (text :read))) + +(defmethod rss-item-title ((item news-item)) + (news-item-title item)) + +(defmethod rss-item-description ((item news-item)) + (news-item-text item)) + +(defmethod rss-item-guid ((item news-item)) + (format nil "~A/~A" *website-url* (store-object-id item))) + +(defmethod rss-item-link ((item news-item)) + (format nil "~A/~A" *website-url* (store-object-id item))) + +(defmethod rss-item-channel ((item news-item)) + "default") + +(defun make-news-item (title text &rest args) + (apply #'make-object 'news-item :title title :text text args)) \ No newline at end of file Modified: branches/xml-class-rework/projects/hello-web/src/packages.lisp =================================================================== --- branches/xml-class-rework/projects/hello-web/src/packages.lisp 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/packages.lisp 2006-07-22 12:58:44 UTC (rev 1970) @@ -41,6 +41,7 @@ :bknr.images :bknr.datastore :bknr.indices + :bknr.rss :hello-web.config :net.aserve :xhtml-generator) Modified: branches/xml-class-rework/projects/hello-web/src/webserver.lisp =================================================================== --- branches/xml-class-rework/projects/hello-web/src/webserver.lisp 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/src/webserver.lisp 2006-07-22 12:58:44 UTC (rev 1970) @@ -9,13 +9,12 @@ (defun publish-hello-web (&key (port *webserver-port*) (listeners 20)) - (setf bknr.web::*login-default-url* "/admin") - (make-instance 'website :name "Hello Web CMS" :handler-definitions `(("/hello-object" hello-object-handler) ("/" redirect-handler :prefix "/" :to "/index") + ("/rss" rss-handler) ("/" template-handler :prefix "/" :destination ,(namestring (merge-pathnames #p"templates/" *website-directory*)) Deleted: branches/xml-class-rework/projects/hello-web/website/templates/index.bknr =================================================================== --- branches/xml-class-rework/projects/hello-web/website/templates/index.bknr 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/website/templates/index.bknr 2006-07-22 12:58:44 UTC (rev 1970) @@ -1,22 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" - "
http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd
"> -<html - xmlns="
http://www.w3.org/1999/xhtml
" - xmlns:bknr="
http://bknr.net
" - xmlns:hello-web="
http://hello-web.bknr.net
" - > - <head> - <link rel="stylesheet" href="/static/styles.css" /> - <script src="/static/javascript.js" type="text/javascript"><!-- x --> - </script> - <title>Hello Web</title> - </head> - - <body id="hello-web"> - <h2>Hello Web!</h2> - <hello-web:test-tag arg="blub" /> - <h2>Handler demo</h2> - <a href="/hello-object/anonymous">see the output of a user-defined handler</a> - </body> -</html> Copied: branches/xml-class-rework/projects/hello-web/website/templates/index.xml (from rev 1969, branches/xml-class-rework/projects/hello-web/website/templates/index.bknr) Deleted: branches/xml-class-rework/projects/hello-web/website/templates/user-error.bknr =================================================================== --- branches/xml-class-rework/projects/hello-web/website/templates/user-error.bknr 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/website/templates/user-error.bknr 2006-07-22 12:58:44 UTC (rev 1970) @@ -1,14 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" - "
http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd
"> -<html - xmlns="
http://www.w3.org/1999/xhtml
" - xmlns:bknr="
http://bknr.net
" - xmlns:lisp-ecoop05="
http://lisp-ecoop05.bknr.net
" - xmlns:menu="
http://bknr.net/menu
" - > -Your request could not be processed because an error occured: -<pre> -$(error-message) -</pre> -</html> \ No newline at end of file Copied: branches/xml-class-rework/projects/hello-web/website/templates/user-error.xml (from rev 1969, branches/xml-class-rework/projects/hello-web/website/templates/user-error.bknr) =================================================================== --- branches/xml-class-rework/projects/hello-web/website/templates/user-error.bknr 2006-07-22 11:30:36 UTC (rev 1969) +++ branches/xml-class-rework/projects/hello-web/website/templates/user-error.xml 2006-07-22 12:58:44 UTC (rev 1970) @@ -0,0 +1,14 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "
http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd
"> +<html + xmlns="
http://www.w3.org/1999/xhtml
" + xmlns:bknr="
http://bknr.net
" + xmlns:lisp-ecoop05="
http://lisp-ecoop05.bknr.net
" + xmlns:menu="
http://bknr.net/menu
" + > +Your request could not be processed because an error occured: +<p> +$(error-message) +</p> +</html> \ No newline at end of file
[View Less]
1
0
0
0
[bknr-cvs] r1969 - in branches/xml-class-rework/projects/quickhoney: src website/templates
by bknr@bknr.net
22 Jul '06
22 Jul '06
Author: hhubner Date: 2006-07-22 07:30:36 -0400 (Sat, 22 Jul 2006) New Revision: 1969 Modified: branches/xml-class-rework/projects/quickhoney/src/image.lisp branches/xml-class-rework/projects/quickhoney/src/packages.lisp branches/xml-class-rework/projects/quickhoney/website/templates/index.xml Log: fix wrong input name for client input while uploading images. add rss feed for new images, frontend not yet done. Modified: branches/xml-class-rework/projects/quickhoney/src/image.lisp ===
…
[View More]
================================================================ --- branches/xml-class-rework/projects/quickhoney/src/image.lisp 2006-07-22 11:29:38 UTC (rev 1968) +++ branches/xml-class-rework/projects/quickhoney/src/image.lisp 2006-07-22 11:30:36 UTC (rev 1969) @@ -1,6 +1,6 @@ (in-package :quickhoney) -(define-persistent-class quickhoney-image (store-image) +(define-persistent-class quickhoney-image (store-image rss-item) ((client :update :initform "" :index-type hash-index :index-initargs (:test #'equal) :index-reader images-for-client @@ -24,4 +24,16 @@ ((animation :update))) (defmethod destroy-object :before ((image quickhoney-animation-image)) - (delete-object (quickhoney-animation-image-animation image))) \ No newline at end of file + (delete-object (quickhoney-animation-image-animation image))) + +(defmethod rss-item-channel ((item quickhoney-image)) + "quickhoney") + +(defmethod rss-item-title ((image quickhoney-image)) + (store-image-name image)) + +(defmethod rss-item-description ((image quickhoney-image)) + (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image))) + +(defmethod rss-item-link ((image quickhoney-image)) + (format nil "
http://quickhoney.com/image/~A
" (store-image-name image))) \ No newline at end of file Modified: branches/xml-class-rework/projects/quickhoney/src/packages.lisp =================================================================== --- branches/xml-class-rework/projects/quickhoney/src/packages.lisp 2006-07-22 11:29:38 UTC (rev 1968) +++ branches/xml-class-rework/projects/quickhoney/src/packages.lisp 2006-07-22 11:30:36 UTC (rev 1969) @@ -29,6 +29,7 @@ :bknr.datastore :bknr.indices :bknr.images + :bknr.rss :quickhoney.config :net.aserve :xhtml-generator) Modified: branches/xml-class-rework/projects/quickhoney/website/templates/index.xml =================================================================== --- branches/xml-class-rework/projects/quickhoney/website/templates/index.xml 2006-07-22 11:29:38 UTC (rev 1968) +++ branches/xml-class-rework/projects/quickhoney/website/templates/index.xml 2006-07-22 11:30:36 UTC (rev 1969) @@ -147,7 +147,7 @@ </p> <p class="cms"> Client:<br /> - <input type="text" id="upload_client" name="upload_client" value="" /><br /> + <input type="text" id="upload_client" name="client" value="" /><br /> <div id="upload_client_select"> </div> </p> @@ -194,7 +194,7 @@ </p> <p class="cms"> Client:<br /> - <input type="text" id="upload_client" name="upload_client" value="" /><br /> + <input type="text" id="upload_client" name="client" value="" /><br /> <div id="upload_animation_client_select"> </div> </p>
[View Less]
1
0
0
0
[bknr-cvs] r1968 - in branches/xml-class-rework/bknr/src: . rss web
by bknr@bknr.net
22 Jul '06
22 Jul '06
Author: hhubner Date: 2006-07-22 07:29:38 -0400 (Sat, 22 Jul 2006) New Revision: 1968 Added: branches/xml-class-rework/bknr/src/rss/test.lisp Modified: branches/xml-class-rework/bknr/src/bknr.asd 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 branches/xml-class-rework/bknr/src/web/web-utils.lisp Log: fix smaller upload problems rewrote rss module, still needs debugging to
…
[View More]
make it work with gmail Modified: branches/xml-class-rework/bknr/src/bknr.asd =================================================================== --- branches/xml-class-rework/bknr/src/bknr.asd 2006-07-16 17:49:02 UTC (rev 1967) +++ branches/xml-class-rework/bknr/src/bknr.asd 2006-07-22 11:29:38 UTC (rev 1968) @@ -34,6 +34,7 @@ :klammerscript :bknr-datastore :bknr-data-impex + :kmrcl #+(not allegro) :acl-compat) Modified: branches/xml-class-rework/bknr/src/packages.lisp =================================================================== --- branches/xml-class-rework/bknr/src/packages.lisp 2006-07-16 17:49:02 UTC (rev 1967) +++ branches/xml-class-rework/bknr/src/packages.lisp 2006-07-22 11:29:38 UTC (rev 1968) @@ -26,7 +26,7 @@ #:start-cron)) (defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls) + (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) (:export #:xml-escape #:*img-src-scanner* #:*a-href-scanner* @@ -37,14 +37,9 @@ #:rss-to-xml #:merge-feeds - ;; feed - #:rss-feed - #:rss-feed-channel - #:rss-feed-image - #:rss-feed-items - ;; channel #:rss-channel + #:rss-channel-cleanup #:rss-channel-about #:rss-channel-title #:rss-channel-link @@ -52,6 +47,7 @@ #:rss-channel-image #:rss-channel-textinput #:rss-channel-items + #:rss-channel-xml ;; image #:rss-image @@ -62,13 +58,16 @@ ;; item #:rss-item - #:rss-item-about + #:rss-item-channel #:rss-item-title #:rss-item-link - #:rss-item-desc - #:rss-item-creator - #:rss-item-date - #:rss-item-orig-feed + #:rss-item-description + #:rss-item-author + #:rss-item-category + #:rss-item-comments + #:rss-item-enclosure + #:rss-item-guid + #:rss-item-source ;; textinput #:rss-textinput @@ -251,6 +250,12 @@ #:navi-button #:with-bknr-http-response + #:upload + #:upload-name + #:upload-pathname + #:upload-size + #:upload-content-type + #:bknr-url-path ;; templates Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-16 17:49:02 UTC (rev 1967) +++ branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-22 11:29:38 UTC (rev 1968) @@ -1,168 +1,134 @@ (in-package :bknr.rss) -(defconstant +rdf-ns+ "
http://www.w3.org/1999/02/22-rdf-syntax-ns#
") -(defconstant +rss-ns+ "
http://purl.org/rss/1.0/
") -(defconstant +dc-ns+ "
http://purl.org/dc/elements/1.1/
") -(defconstant +content-ns+ "
http://purl.org/rss/1.0/modules/content/
") +;; RSS 2.0 Generation Package -(defgeneric rss-to-xml (rss-element)) +;; This package aids in the automatic generation of RSS channels. -(defun xml-escape (xml-string) - (apply #'concatenate 'string - (loop for c across xml-string - collect (case c - ((#\<) "<") - ((#\>) ">") - ((#\&) "&") - ((#\') "'") - ((#\") """) - (t (string c)))))) +;; Class 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 is +;; automatically added to its RSS channel. Likewise, it is +;; automatically deleted from the channel when it is deleted. +;; The channel that an item is put into is defined by the generic +;; function rss-item-channel which needs to be specialized for each +;; item class. The default method of this generic function specifies +;; nil as channel, which results in the creation of a warning message +;; when an object of this class is created. -(defun rss10-content (content) - `(("description") NIL ,content)) +;; The rss-item-channel method may return the channel either as a +;; string or as a channel object. -(defun rss10-tzd (zone) - (if (> zone 0) - (format nil "+~2,'0D" zone) - (format nil "-~2,'0D" (- zone)))) +;; Subclasses of rss-item should provide methods for some of the +;; generic functions (rss-item-channel rss-item-title rss-item-link +;; rss-item-description rss-item-author rss-item-category +;; rss-item-comments rss-item-enclosure rss-item-guid +;; rss-item-source). These functions are called when the RSS file for +;; the channel is generated and provide the -(defun rss10-date (date) - (multiple-value-bind (second minute hour date month year day daylight zone) - (decode-universal-time date) - (declare (ignore day daylight)) - (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~a:00" - year month date hour minute second - (rss10-tzd zone)))) +;; One rss-item can only be in one channel. -(defclass rss-feed () - ((channel :initarg :channel :accessor rss-feed-channel :initform nil) - (image :initform nil :initarg :image :accessor rss-feed-image) - (items :initarg :items :accessor rss-feed-items :initform nil))) +;;; Paul Graham, On Lisp, p191 +(defmacro aif (test-form then-form &optional else-form) + `(let ((it ,test-form)) + (if it ,then-form ,else-form))) -(defmethod rss-feed-items-with-title ((feed rss-feed)) - (let ((feed-title (rss-channel-title (rss-feed-channel feed)))) - (mapcar #'(lambda (item) - (with-slots (title about link desc creator date) item - (make-instance 'rss-item - :title (format nil "~a - ~a" - feed-title title) - :about about - :orig-feed feed - :link link - :desc desc - :creator creator - :date date))) - (rss-feed-items feed)))) +(define-persistent-class rss-channel () + ((name :update + :index-type string-unique-index + :index-reader find-rss-channel) + (title :update) + (link :update) + (description :update) + (last-update :update :initform (get-universal-time)) + (max-item-age :update :initform (* 7 3600)) + (items :update :initform nil))) -(defun merge-feeds (title url desc feeds) - (let ((items (subseq (sort (apply #'append (mapcar #'rss-feed-items-with-title feeds)) - #'> :key #'rss-item-date) - 0 30))) - (make-instance 'rss-feed - :channel (make-instance 'rss-channel :title title - :link url - :desc desc - :items (mapcar #'rss-item-link items)) - :items items))) +(defun render-mandatory-element (channel element) + (with-element (string-downcase (symbol-name element)) + (text (aif (and (slot-boundp channel element) + (slot-value channel element)) + it + (format nil "(channel ~(~A~) not defined)" element))))) -(defmethod rss-to-xml ((feed rss-feed)) - (make-node :name "rdf:RDF" - :ns +rss-ns+ - :attrs `(("xmlns:rdf" ,+rdf-ns+) - ("xmlns:dc" ,+dc-ns+)) - :children (append (list (rss-to-xml (rss-feed-channel feed))) - (if (rss-feed-image feed) - (list (rss-to-xml (rss-feed-image feed))) - nil) - (mapcar #'rss-to-xml (rss-feed-items feed))))) +(defmethod rss-channel-xml ((channel rss-channel) stream) + (with-xml-output (make-character-stream-sink stream) + (with-element "rss" + (attribute "version" "2.0") + (with-element "channel" + (dolist (slot '(title description link)) + (render-mandatory-element channel slot)) + (dolist (item (rss-channel-items channel)) + (rss-item-xml item)))))) -(defclass rss-channel () - ((about :initarg :about :accessor rss-channel-about :initform nil) - (title :initarg :title :accessor rss-channel-title :initform nil) - (link :initarg :link :accessor rss-channel-link :initform nil) - (desc :initarg :desc :accessor rss-channel-desc :initform nil) - (image :initform nil :initarg :image :accessor rss-channel-image) - (textinput :initform nil :initarg :textinput :accessor rss-channel-textinput) - (items :initform nil :initarg :items :accessor rss-channel-items))) +(defmethod rss-channel-items ((channel rss-channel)) + "Return all non-expired items in channel." + (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel)))) + (remove-if (lambda (item) (< (rss-item-pub-date item) expiry-time)) (slot-value channel 'items)))) -(defmethod rss-to-xml ((chan rss-channel)) - `(("channel") - (("rdf:about" ,(or (rss-channel-about chan) "nothing"))) - ,@(remove nil - `((("title") NIL ,(rss-channel-title chan)) - (("link" ) NIL ,(rss-channel-link chan)) - ,(when (rss-channel-desc chan) - `(("description") NIL ,(rss-channel-desc chan))) - ,(when (rss-channel-image chan) - `(("image") - (("rdf:resource" ,(rss-image-url (rss-channel-image chan)))))) - ,(when (rss-channel-items chan) - `(("items") - NIL - ("rdf:Seq" NIL - ,@(mapcar #'(lambda (item) - `("rdf:li" (("rdf:resource" - ,(if (typep item 'rss-item) - (rss-item-link item) - item))))) - (rss-channel-items chan))))) - ,(when (rss-channel-textinput chan) - `(("textinput") - (("rdf:resource" . ,(rss-textinput-link - (rss-channel-textinput chan)))))))))) +(deftransaction rss-channel-cleanup (channel) + "Remove expired items from the items list. Can be used to reduce +the memory footprint of very high volume channels." + (setf (slot-value channel 'items) (rss-channel-items channel))) -(defclass rss-image () - ((about :initarg :about :accessor rss-image-about :initform nil) - (title :initarg :title :accessor rss-image-title :initform nil) - (url :initarg :url :accessor rss-image-url :initform nil) - (link :initarg :link :accessor rss-image-link :initform nil))) +;; Internal helper functions to find a channel -(defmethod rss-to-xml ((image rss-image)) - `(("image") - (("rdf:about" ,(or (rss-image-about image) "nothing"))) - (("title") NIL ,(rss-image-title image)) - (("link" ) NIL ,(rss-image-link image)) - (("url" ) NIL ,(rss-image-url image)))) +(defmethod remove-item ((channel rss-channel) (item rss-item)) + "Remove item from channel. May only be called within transaction context." + (setf (slot-value channel 'items) (remove item (rss-channel-items channel)))) -(defclass rss-item () - ((about :initarg :about :accessor rss-item-about :initform nil) - (title :initarg :title :accessor rss-item-title) - (link :initarg :link :accessor rss-item-link) - (desc :initform nil :initarg :desc :accessor rss-item-desc) - (creator :initarg :creator :accessor rss-item-creator :initform nil) - (date :initarg :date :accessor rss-item-date :initform 0) - (orig-feed :initarg :orig-feed :accessor rss-item-orig-feed :initform nil))) +(defmethod remove-item ((channel string) (item rss-item)) + (aif (find-rss-channel channel) + (remove-item it item))) -(defmethod rss-to-xml ((item rss-item)) - `(("item") - (("rdf:about" ,(or (rss-item-about item) "nothing"))) - ,@(remove - nil - `((("title") NIL ,(rss-item-title item)) - (("link" ) NIL ,(rss-item-link item)) - ,(when (rss-item-desc item) - (rss10-content (rss-item-desc item))) - ,(when (rss-item-creator item) - `("dc:creator" - NIL - ,(rss-item-creator item))) - ,(when (rss-item-date item) - `("dc:date" - NIL - ,(rss10-date (rss-item-date item)))))))) +(defmethod remove-item ((channel (eql nil)) (item rss-item)) + (warn "no RSS channel defined for item ~A" item)) -(defclass rss-textinput () - ((about :initarg :about :accessor rss-textinput-about :initform nil) - (title :initarg :title :accessor rss-textinput-title) - (desc :initarg :desc :accessor rss-textinput-desc) - (link :initarg :link :accessor rss-textinput-link) - (name :initarg :name :accessor rss-textinput-name))) +(defmethod add-item ((channel rss-channel) (item rss-item)) + "Add item to channel. May only be called within transaction context." + (setf (slot-value channel 'items) (cons item (rss-channel-items channel)))) -(defmethod rss-to-xml ((textinput rss-textinput)) - `(("textinput") - (("rdf:about" ,(or (rss-textinput-about textinput) "nothing"))) - (("title") NIL ,(rss-textinput-title textinput)) - (("link" ) NIL ,(rss-textinput-link textinput)) - (("name" ) NIL ,(rss-textinput-name textinput)) - (("description") NIL ,(rss-textinput-desc textinput)))) +(defmethod add-item ((channel string) (item rss-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)) + (warn "no RSS channel defined for item ~A" item)) + +;; Mixin for items + +(define-persistent-class rss-item () + ((pub-date :read))) + +(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-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 '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)) + (with-element "item" + (dolist (slot '(title link description author category comments enclosure guid source)) + (item-slot-element item slot)) + (with-element "pubDate" + (text (format-date-time (rss-item-pub-date item) :mail-style t))))) + Added: branches/xml-class-rework/bknr/src/rss/test.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/test.lisp 2006-07-16 17:49:02 UTC (rev 1967) +++ branches/xml-class-rework/bknr/src/rss/test.lisp 2006-07-22 11:29:38 UTC (rev 1968) @@ -0,0 +1,15 @@ +(make-package :bknr.rss.test) +(in-package :bknr.rss.test) +(use-package :bknr.rss) +(use-package :bknr.datastore) + +(define-persistent-class test-item (rss-item) + ()) + +(defmethod rss-item-channel ((item test-item)) + "blub") + +(defmethod rss-item-author ((item test-item)) + "Hans Hübner") + +(open-store "/tmp/datastore/") \ No newline at end of file Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-07-16 17:49:02 UTC (rev 1967) +++ branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-07-22 11:29:38 UTC (rev 1968) @@ -237,7 +237,7 @@ (error e)))) (handle handler req))) (handler-case - (mapcar #'delete-file (mapcar #'cdr (getf (request-reply-plist req) 'uploaded-files))) + (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files req))) (error (e) (warn "error ~A ignored while deleting uploaded files" e))))) Modified: branches/xml-class-rework/bknr/src/web/web-utils.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-07-16 17:49:02 UTC (rev 1967) +++ branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-07-22 11:29:38 UTC (rev 1968) @@ -2,6 +2,8 @@ (enable-interpol-syntax) +(defstruct upload name pathname content-type) + (defgeneric object-url (obj)) (defgeneric edit-object-url (obj)) (defgeneric html-link (obj)) @@ -31,7 +33,6 @@ (loop (multiple-value-bind (kind part-name file-name content-type) (parse-multipart-header (get-multipart-header request)) - (declare (ignore content-type)) (case kind (:eof (return)) (:data (push (cons part-name (get-all-multipart-data request)) parameters)) @@ -53,7 +54,8 @@ :if-exists :error :element-type '(unsigned-byte 8)) (write-sequence contents temporary-file)) - (push (cons part-name uploaded-file-name) uploaded-files)))))) + (push (make-upload :name part-name :pathname uploaded-file-name + :content-type content-type) uploaded-files)))))) (t (get-all-multipart-data request :limit *upload-file-size-limit*))))) (when file-size-limit-reached @@ -91,10 +93,15 @@ (parse-request-body request :uploads t) (setf (getf (request-reply-plist request) 'body-parsed) t))) -(defun request-uploaded-files (request) - "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user" +(defun request-uploaded-files (request &key all-info) + "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user. +If :all-info is non-nil, the full upload file information is returned as a list" (get-parameters-from-body request) - (getf (request-reply-plist request) 'uploaded-files)) + (if all-info + (getf (request-reply-plist request) 'uploaded-files) + (mapcar (lambda (upload) (cons (upload-name upload) + (upload-pathname upload))) + (getf (request-reply-plist request) 'uploaded-files)))) (defun request-uploaded-file (request parameter-name) (cdr (find parameter-name (request-uploaded-files request) :test #'equal :key #'car)))
[View Less]
1
0
0
0
[bknr-cvs] r1967 - in branches/xml-class-rework/projects/bos: . payment-website/infosystem payment-website/static payment-website/templates/de
by bknr@bknr.net
16 Jul '06
16 Jul '06
Author: hhubner Date: 2006-07-16 13:49:02 -0400 (Sun, 16 Jul 2006) New Revision: 1967 Modified: branches/xml-class-rework/projects/bos/make-base-lisp.lisp branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js branches/xml-class-rework/projects/bos/payment-website/static/bos.js branches/xml-class-rework/projects/bos/payment-website/static/content_style.css branches/xml-class-rework/projects/bos/payment-website/static/toplevel_style.css branches/xml-
…
[View More]
class-rework/projects/bos/payment-website/templates/de/toplevel_main.xml Log: Login panel on home page added Modified: branches/xml-class-rework/projects/bos/make-base-lisp.lisp =================================================================== --- branches/xml-class-rework/projects/bos/make-base-lisp.lisp 2006-07-16 13:41:47 UTC (rev 1966) +++ branches/xml-class-rework/projects/bos/make-base-lisp.lisp 2006-07-16 17:49:02 UTC (rev 1967) @@ -1,8 +1,8 @@ ;; create base lisp image -(compile-file "../bknr/patches/patch-around-mop-cmucl19a.lisp") -(load "../bknr/patches/patch-around-mop-cmucl19a.x86f") -(load "../thirdparty/asdf/asdf.lisp") +(compile-file "../../bknr/patches/patch-around-mop-cmucl19a.lisp") +(load "../../bknr/patches/patch-around-mop-cmucl19a.x86f") +(load "../../thirdparty/asdf/asdf.lisp") (defun setup-registry () (format t "; setting up ASDF registry, please be patient...") @@ -11,12 +11,12 @@ (pushnew (make-pathname :directory (pathname-directory asd-pathname)) asdf:*central-registry* :test #'equal)) - (remove "asd" (directory #p"../**/") + (remove "asd" (directory #p"../../**/") :test (complement #'equal) :key #'pathname-type)) (format t " ~D directories found~%" (length asdf:*central-registry*))) (setup-registry) -(save-lisp "home:cmucl.core") +(save-lisp "cmucl.core") Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-07-16 13:41:47 UTC (rev 1966) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-07-16 17:49:02 UTC (rev 1967) @@ -215,6 +215,14 @@ timer = 0; var user = document.form0.__sponsorid.value; var password = document.form0.__password.value; + + var current_url = '' + document.location; + + if (user == '' && current_url.match(/__sponsorid/)) { + user = current_url.replace(/.*__sponsorid=([^?]*).*/, "$1"); + password = current_url.replace(/.*__password=([^?]*).*/, "$1"); + } + var url = http_pfad + "/sponsor-login"; if (user != "") { url += "?__sponsorid=" + user + "&__password=" + password; Modified: branches/xml-class-rework/projects/bos/payment-website/static/bos.js =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/static/bos.js 2006-07-16 13:41:47 UTC (rev 1966) +++ branches/xml-class-rework/projects/bos/payment-website/static/bos.js 2006-07-16 17:49:02 UTC (rev 1967) @@ -1,4 +1,4 @@ - +// -*- Java -*- Script // *** extrafenster fuer impressum, kontakt etc. *** // function window_extra(target) { mywin=open(target,"detailwin","width=482,height=600,status=no,toolbar=no,menubar=no,resizable=yes,scrollbars=yes,left=100,top=100"); @@ -22,9 +22,18 @@ // *** extrafenster fuer satellitenkarte *** // function window_infosys() { var language = document.location.pathname.substr(1, 2); // XXX funktioniert nur mit 2-buchstaben-abkuerzungen von sprachen - mywin=open("/infosystem/" + language + "/satellitenkarte.htm", - "infowin", - "width=740,height=500,status=no,toolbar=no,menubar=no,resizable=no,scrollbars=no,left=250,top=50"); + var url = "/infosystem/" + language + "/satellitenkarte.htm"; + + var sponsorid_input = document.getElementById('sponsorid-input'); + var password_input = document.getElementById('password-input'); + + if (sponsorid_input && password_input) { + url += "?__sponsorid=" + sponsorid_input.value + "&__password=" + password_input.value; + } + + mywin=open(url, + "infowin", + "width=740,height=500,status=no,toolbar=no,menubar=no,resizable=no,scrollbars=no,left=250,top=50"); mywin.focus(); }; Modified: branches/xml-class-rework/projects/bos/payment-website/static/content_style.css =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/static/content_style.css 2006-07-16 13:41:47 UTC (rev 1966) +++ branches/xml-class-rework/projects/bos/payment-website/static/content_style.css 2006-07-16 17:49:02 UTC (rev 1967) @@ -15,7 +15,7 @@ width: 150px; max-width: 150px; padding-bottom: 0px; - margin : 58px 15px 10px 15px; + margin : 5px 15px 10px 15px; border-width: 1px; border-style: solid solid solid solid; border-color : Silver; @@ -33,7 +33,7 @@ width: 150px; height: 398px; max-width: 150px; - margin : 28px 15px 10px 15px; + margin : 5px 15px 10px 15px; visibility: visible; display: block; font : normal normal 0.7em Verdana, Geneva, Arial, Helvetica, sans-serif; @@ -50,9 +50,9 @@ width: 150px; max-width: 150px; height: 180px; - margin : 22px 15px 10px 15px; + margin : 0px 15px 10px 15px; border-width: 1px; - border-style: solid solid none solid; + border-style: solid solid solid solid; border-color : Silver; visibility: visible; display: block; @@ -65,6 +65,34 @@ background-position : bottom; } +/* Login-Formular auf der HP */ +#textbox_left_login { + position: relative; + background-color: white; + z-index: 20; + width: 150px; + max-width: 150px; + height: 85px; + margin : 0px 15px 0px 15px; + border-width: 1px; + border-style: solid solid solid solid; + border-color : Silver; + visibility: visible; + display: block; + font : normal normal 0.7em Verdana, Geneva, Arial, Helvetica, sans-serif; + color : #333333; + font-weight : normal; + text-decoration : none; +} + +.password-input { + width: 115px; +} + +.login-button { + top: 5px; +} + #textbox_right { position: relative; Modified: branches/xml-class-rework/projects/bos/payment-website/static/toplevel_style.css =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/static/toplevel_style.css 2006-07-16 13:41:47 UTC (rev 1966) +++ branches/xml-class-rework/projects/bos/payment-website/static/toplevel_style.css 2006-07-16 17:49:02 UTC (rev 1967) @@ -351,7 +351,7 @@ #menue_footer { position: relative; z-index: 15; - margin-top: 20px; + margin-top: 5px; margin-left: 0px; width: 186px; height: 20px; 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-07-16 13:41:47 UTC (rev 1966) +++ branches/xml-class-rework/projects/bos/payment-website/templates/de/toplevel_main.xml 2006-07-16 17:49:02 UTC (rev 1967) @@ -148,6 +148,34 @@ </tr> </table> </div> + <div id="textbox_left_login"> + <form> + <table border="0" cellpadding="0" cellspacing="0"> + <tr><td colspan="4" height="6"></td></tr> + <tr> + <td width="6"> </td> + <td colspan="2"><strong>Sponsor-ID</strong></td> + <td width="6"></td> + </tr> + <tr> + <td width="6"> </td> + <td colspan="2"><input id="sponsorid-input" type="text" name="__sponsorid"/></td> + <td width="6"></td> + </tr> + <tr> + <td width="6"> </td> + <td colspan="2"><strong>Kennwort</strong></td> + <td width="6"></td> + </tr> + <tr> + <td width="6"> </td> + <td colspan="2"><input id="password-input" class="password-input" type="password" name="__password"/> + <img onclick="window_infosys()" class="login-button" src="/infosystem/bilder/submit.gif"/></td> + <td width="6"></td> + </tr> + </table> + </form> + </div> <!-- footer --> <div id="menue_footer"> <a href="javascript:window_extra('privacy')" class="footer">
[View Less]
1
0
0
0
[bknr-cvs] r1966 - in branches/xml-class-rework/projects/quickhoney: src website/static website/templates
by bknr@bknr.net
16 Jul '06
16 Jul '06
Author: hhubner Date: 2006-07-16 09:41:47 -0400 (Sun, 16 Jul 2006) New Revision: 1966 Modified: branches/xml-class-rework/projects/quickhoney/src/handlers.lisp branches/xml-class-rework/projects/quickhoney/website/static/javascript.js branches/xml-class-rework/projects/quickhoney/website/templates/index.xml Log: Make contact image user-replaceable. Modified: branches/xml-class-rework/projects/quickhoney/src/handlers.lisp ===============================================================
…
[View More]
==== --- branches/xml-class-rework/projects/quickhoney/src/handlers.lisp 2006-07-16 11:49:47 UTC (rev 1965) +++ branches/xml-class-rework/projects/quickhoney/src/handlers.lisp 2006-07-16 13:41:47 UTC (rev 1966) @@ -151,7 +151,7 @@ (handler-case (progn (unless uploaded-file - (error "no file uploaded in upload handler")) + (error "no file uploaded")) (cl-gd:with-image-from-file* (uploaded-file) (let* ((color-table (make-hash-table :test #'eql)) (width (cl-gd:image-width)) @@ -187,7 +187,7 @@ (:body (:h2 "Error during upload") (:p "Error during upload:") - (:pre (:princ-safe e)) + (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (:p ((:a :href "javascript:window.close()") "ok")))))))))))) (defclass upload-animation-handler (admin-only-handler page-handler) @@ -249,7 +249,7 @@ (not (equal "" subdirectory))) (error "no subcategory selected, upload not accepted")) (unless uploaded-file - (error "no file uploaded in upload handler")) + (error "no file uploaded")) (cl-gd:with-image-from-file* (uploaded-file) (unless (and (eql 208 (cl-gd:image-width)) (eql 208 (cl-gd:image-height))) @@ -278,5 +278,5 @@ (:body (:h2 "Error during upload") (:p "Error during upload:") - (:pre (:princ-safe e)) + (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (:p ((:a :href "javascript:window.close()") "ok")))))))))))) Modified: branches/xml-class-rework/projects/quickhoney/website/static/javascript.js =================================================================== --- branches/xml-class-rework/projects/quickhoney/website/static/javascript.js 2006-07-16 11:49:47 UTC (rev 1965) +++ branches/xml-class-rework/projects/quickhoney/website/static/javascript.js 2006-07-16 13:41:47 UTC (rev 1966) @@ -155,7 +155,7 @@ document.getElementById("image_detail").innerHTML = ''; if (current_directory == 'quickhoney') { load_button_images(); - setTimeout("if (current_directory == 'quickhoney') { show_cms_window('edit_quickhoney_form'); }", 2000); + setTimeout("if (current_directory == 'quickhoney') { show_cms_window('edit_quickhoney_form'); } else if (current_directory == 'contact') { show_cms_window('edit_contact_form'); }", 2000); } else { setTimeout("if (!current_image) { show_cms_window('upload_form'); }", 2000); do_query(); @@ -366,6 +366,12 @@ ['000000', 'ffffff', '9900ff'], function() { footer_hide(); + + if (button_images['contact/contact']) { + document.getElementById("contactimage").src = button_images['contact/contact']; + } + + current_directory = 'contact'; }); function preload_menu_images() { @@ -425,6 +431,8 @@ if (logged_in) { if (current_directory == "quickhoney") { show_cms_window("edit_quickhoney_form"); + } else if (current_directory == "contact") { + show_cms_window("edit_contact_form"); } else if (current_directory && current_subdirectory) { if (current_image) { show_cms_window('edit_form'); @@ -548,6 +556,22 @@ } } +/* contact image */ + +function contact_loaded(image) { + + debug('contact_loaded - image is ' + image + ' width: ' + image.width); + + reveal_image(image); + + if (logged_in) { + var current_contact_image = image.src.substring(image.src.indexOf('/image/') + 7); + if (current_contact_image != 'trans') { + document.getElementById("delete_contactimage_form_element").setAttribute("action", "/edit-image-js/" + current_contact_image); + } + } +} + /* directory - first level category */ var button_images = []; @@ -557,10 +581,13 @@ button_images = _button_images; if (current_directory == 'quickhoney' + || current_directory == 'contact' || (document.getElementById("homeimage").src.indexOf("trans") != -1)) { document.getElementById("homeimage").style.visibility = 'hidden'; document.getElementById("homeimage").src = button_images['home/home']; + + document.getElementById("contactimage").src = button_images['contact/contact']; } } @@ -570,7 +597,8 @@ + '/home/home' + '/pixel/' + directory_button['pixel'].join(',') + '/vector/' + directory_button['vector'].join(',') - + '/photo,000000/' + directory_button['photo'].join(',')); + + '/photo,000000/' + directory_button['photo'].join(',') + + '/contact/contact'); } function directory(directory_name) { Modified: branches/xml-class-rework/projects/quickhoney/website/templates/index.xml =================================================================== --- branches/xml-class-rework/projects/quickhoney/website/templates/index.xml 2006-07-16 11:49:47 UTC (rev 1965) +++ branches/xml-class-rework/projects/quickhoney/website/templates/index.xml 2006-07-16 13:41:47 UTC (rev 1966) @@ -105,7 +105,7 @@ <div id="contact"> <div id="contact-bigimage"> - <img src="/image/contact-peter-nana" /> + <img id="contactimage" src="/image/trans" onload="contact_loaded(this);"/> </div> <img class="contact" src="/image/type_contact_email" /> <p class="contact"> @@ -238,6 +238,23 @@ </form> </div> + <div id="edit_contact_form" class="cms_form"> + <div class="cms_title">Upload home image</div> + <form action="/upload-image/contact/button" method="post" + enctype="multipart/form-data" target="upload_result" onsubmit="do_upload(this.target);"> + <p class="cms"> + <input type="file" name="image-file" /><br /> + </p> + <p class="cms"> + <input type="submit" name="action" value="upload" /> + </p> + </form> + <div class="cms_title">Delete this home image</div> + <form id="delete_contactimage_form_element" action="/edit-image-js" target="edit_iframe" method="post"> + <input type="submit" name="action" value="delete" onclick="return confirm('Really delete this contact image?');" /> + </form> + </div> + <div id="saving_edits_form" class="cms_form"> <div class="cms_title">Saving Edits</div> <p class="cms">
[View Less]
1
0
0
0
← Newer
1
2
Older →
Jump to page:
1
2
Results per page:
10
25
50
100
200