July 2006 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[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 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');

1 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) +++ 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"> </script> <title>QuickHoney - Nana Rausch + Peter Stemmler</title>

1 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/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*)

1 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 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)))))

1 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/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*)))))

1 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: 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"> - </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

1 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 =================================================================== --- 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>

1 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 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)))

1 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-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>  <div id="menue_footer"> <a href="javascript:window_extra('privacy')" class="footer">

1 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 =================================================================== --- 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">

1 0