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

[bknr-cvs] ksprotte changed trunk/bknr/web/src/web/web-
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3720 Author: ksprotte URL: http://bknr.net/trac/changeset/3720 BKNR web: QUERY-PARAM and WITH-QUERY-PARAMS now support conversion from the value string to an optionally specified type. U trunk/bknr/web/src/web/web-macros.lisp U trunk/bknr/web/src/web/web-utils.lisp Modified: trunk/bknr/web/src/web/web-macros.lisp =================================================================== --- trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 12:08:44 UTC (rev 3719) +++ trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 12:50:18 UTC (rev 3720) @@ -19,20 +19,31 @@ names) ,@body)) -(defmacro with-query-params ((&rest params) &body body) - (let ((vars (loop for param in params - when (and (symbolp param) - (not (null param))) - collect (list param `(query-param ,(string-downcase (symbol-name param)))) - when (consp param) - collect (list (car param) - `(or (parameter ,(string-downcase (symbol-name (car param)))) - ,(second param)))))) - (if vars - `(let ,vars - ,@body) - (first body)))) +(defmacro with-query-params ((&rest parameters) &body body) + "PARAMETERS is a list of parameter-specifiers. A parameter-specifier +has the form (VARIABLE &OPTIONAL DEFAULT-VALUE TYPE) or can be a +single VARIABLE. +If the TYPE is specified, the value is converted like in +HUNCHENTOOT:DEFINE-EASY-HANDLER when PARAMETER-TYPE is given. + +With respect to the conversion of an empty string, there is a subtle +difference between the TYPE specified as STRING and the TYPE left +unspecified. In the former case, the converted value will still be an +empty string, while in the latter VARIABLE will be bound to NIL." + (flet ((parameter-binding (parameter-specifier) + (destructuring-bind (variable &optional default-value type) + (ensure-list parameter-specifier) + (let ((query-param-form (if type + `(query-param ,(string-downcase variable) :type ',type) + `(query-param ,(string-downcase variable))))) + `(,variable + ,(if default-value + `(or ,query-param-form ,default-value) + query-param-form)))))) + `(let ,(mapcar #'parameter-binding parameters) + ,@body))) + (defmacro form-case (&rest cases) `(cond ,@(mapcar #'(lambda (c) Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 12:08:44 UTC (rev 3719) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 12:50:18 UTC (rev 3720) @@ -70,10 +70,12 @@ (append (when get (get-parameters*)) (when post (post-parameters*)))) -(defun query-param (param-name &key (get t) (post t)) +(defun query-param (param-name &key (get t) (post t) type) (let ((value (cdr (assoc param-name (query-params :get get :post post) :test #'string-equal)))) - (unless (equal value "") - value))) + (if type + (hunchentoot::convert-parameter value type) + (unless (equal value "") + value)))) (defun query-param-list (param-name &key (get t) (post t)) (assoc-values param-name (query-params :get get :post post)

1 0

[bknr-cvs] ksprotte changed trunk/bknr/web/src/web/web-
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3719 Author: ksprotte URL: http://bknr.net/trac/changeset/3719 whitespace cleanup and a tiny bit of refactoring in bknr web U trunk/bknr/web/src/web/web-macros.lisp U trunk/bknr/web/src/web/web-utils.lisp Modified: trunk/bknr/web/src/web/web-macros.lisp =================================================================== --- trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 10:14:42 UTC (rev 3718) +++ trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 12:08:44 UTC (rev 3719) @@ -13,81 +13,83 @@ (defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args)) -(defmacro with-cookies ((&rest names) &rest body) +(defmacro with-cookies ((&rest names) &body body) `(let ,(mapcar #'(lambda (name) - `(,name (cookie-in ,(symbol-name name)))) - names) - ,@body)) + `(,name (cookie-in ,(symbol-name name)))) + names) + ,@body)) -(defmacro with-query-params ((&rest params) &rest body) +(defmacro with-query-params ((&rest params) &body body) (let ((vars (loop for param in params - when (and (symbolp param) - (not (null param))) - collect (list param `(query-param ,(string-downcase (symbol-name param)))) - when (consp param) - collect (list (car param) - `(or (parameter ,(string-downcase (symbol-name (car param)))) - ,(second param)))))) + when (and (symbolp param) + (not (null param))) + collect (list param `(query-param ,(string-downcase (symbol-name param)))) + when (consp param) + collect (list (car param) + `(or (parameter ,(string-downcase (symbol-name (car param)))) + ,(second param)))))) (if vars - `(let ,vars - ,@body) - (first body)))) + `(let ,vars + ,@body) + (first body)))) (defmacro form-case (&rest cases) `(cond - ,@(mapcar #'(lambda (c) - (if (eql (car c) t) - `(t ,@(cdr c)) - `((parameter ,(symbol-name (car c))) - (with-query-params (,@(cadr c)) - ,@(cddr c))))) - cases))) + ,@(mapcar #'(lambda (c) + (if (eql (car c) t) + `(t ,@(cdr c)) + `((parameter ,(symbol-name (car c))) + (with-query-params (,@(cadr c)) + ,@(cddr c))))) + cases))) -(defmacro with-http-response ((&key (content-type "text/html") (response +http-ok+)) &rest body) +(defmacro with-http-response ((&key (content-type "text/html") (response +http-ok+)) &body body) `(progn - (setf (content-type) ,content-type) - (setf (return-code) ,response) - ,@body)) + (setf (content-type) ,content-type) + (setf (return-code) ,response) + ,@body)) (defmacro with-http-body ((&key external-format) &body body) + (when external-format + (warn "EXTERNAL-FORMAT is ignored in WITH-HTTP-BODY")) `(with-output-to-string (stream) - (with-xhtml (stream) - ,@body))) + (with-xhtml (stream) + ,@body))) -(defmacro with-image-from-uri ((image-variable prefix) &rest body) +(defmacro with-image-from-uri ((image-variable prefix) &body body) `(multiple-value-bind - (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (script-name*)) - (unless match - (http-error +http-bad-request+ "bad request - missing image path or loid")) - (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) - (unless ,image-variable - (http-error +http-not-found+ "image not found")) - ,@body))) + (match strings) + (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (script-name*)) + (unless match + (http-error +http-bad-request+ "bad request - missing image path or loid")) + (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) + (unless ,image-variable + (http-error +http-not-found+ "image not found")) + ,@body))) -(defmacro define-bknr-tag (name (&rest args) &rest body) +(defmacro define-bknr-tag (name (&rest args) &body body) `(prog1 - (defun ,name (,@args) - ,@body) - (register-tag-function ,(package-name *package*) ,(symbol-name name) (fdefinition ',name)))) + (defun ,name (,@args) + ,@body) + (register-tag-function ,(package-name *package*) ,(symbol-name name) (fdefinition ',name)))) (defmacro html-text-input (variable size &optional maxsize) - `((:input :type "text" - :size ,(format nil "~a" size) - :maxsize ,(format nil "~a" (or maxsize size)) - :name ,(symbol-name variable) - :value ,(or variable "")))) + `((:input :type "text" + :size ,(format nil "~a" size) + :maxsize ,(format nil "~a" (or maxsize size)) + :name ,(symbol-name variable) + :value ,(or variable "")))) (defmacro html-warn (&rest warning) "Generate a warning on the console and write the warning into the currently generated XHTML output as a comment." `(progn - (html (:princ-safe (format nil "~%" (format nil ,@warning)))) - (warn ,@warning))) + (html (:princ-safe (format nil "~%" (format nil ,@warning)))) + (warn ,@warning))) (defmacro cmslink (url &body body) `(html ((:a :class "cmslink" :href (website-make-path *website* ,url)) - ,@body))) + ,@body))) (defvar *xml-sink*) @@ -96,7 +98,7 @@ `(with-http-response (:content-type ,content-type) (with-query-params (download) (when download - (setf (hunchentoot:header-out :content-disposition) + (setf (hunchentoot:header-out :content-disposition) (format nil "attachment; filename=~A" download)))) (with-output-to-string (s) (let ((*xml-sink* (cxml:make-character-stream-sink s :canonical nil))) Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 10:14:42 UTC (rev 3718) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 12:08:44 UTC (rev 3719) @@ -18,7 +18,7 @@ (defun redirect-uri (uri) (make-instance 'uri :path (uri-path uri) - :query (uri-query uri))) + :query (uri-query uri))) (defun request-uploaded-files () "Return a list of UPLOAD structures describing the file uploads in the request." @@ -27,7 +27,8 @@ (let ((uploads (remove-if-not #'listp (post-parameters*) :key #'cdr)) retval) (dolist (upload-info uploads) (destructuring-bind (name pathname original-filename content-type) upload-info - (push (make-upload :name name :pathname pathname :original-filename original-filename :content-type content-type) retval))) + (push (make-upload :name name :pathname pathname :original-filename original-filename + :content-type content-type) retval))) (nreverse retval)))) (aux-request-value 'uploaded-files)) @@ -36,12 +37,13 @@ (defmacro with-image-from-upload ((image upload &rest args) &body body) `(with-image-from-file (,image (upload-pathname ,upload) - (make-keyword-from-string (pathname-type (upload-original-filename ,upload))) ,@args) - ,@body)) + (make-keyword-from-string (pathname-type (upload-original-filename ,upload))) + ,@args) + ,@body)) (defmacro with-image-from-upload* ((upload &rest args) &body body) `(with-image-from-upload (cl-gd:*default-image* ,upload ,@args) - ,@body)) + ,@body)) (defmethod bknr.images:import-image ((upload upload) &rest args &key &allow-other-keys) (apply #'bknr.images:import-image (upload-pathname upload) @@ -56,12 +58,12 @@ macro after the request body has been executed." (unless (aux-request-value 'bknr-parsed-parameters) (setf (aux-request-value 'bknr-parsed-parameters) - (remove-if (lambda (value) - "Remove empty strings (reported as NIL) and uploaded files" - (or (equal value "") - (listp value))) - (query-params) - :key #'cdr))) + (remove-if (lambda (value) + "Remove empty strings (reported as NIL) and uploaded files" + (or (equal value "") + (listp value))) + (query-params) + :key #'cdr))) (aux-request-value 'bknr-parsed-parameters)) (defun query-params (&key (get t) (post t)) @@ -85,8 +87,8 @@ (defun request-variables () (loop for key being the hash-keys of *req-var-hash* - collect key - collect (request-variable key))) + collect key + collect (request-variable key))) (defun http-error (response message) (with-bknr-page (:title #?"error: $(message)" :response response) @@ -95,19 +97,19 @@ (defun keywords-from-query-param-list (param &key (remove-empty t)) (let ((keywords (mapcar #'(lambda (s) - (make-keyword-from-string (string-trim '(#\Space #\Tab #\Newline) s))) - param))) + (make-keyword-from-string (string-trim '(#\Space #\Tab #\Newline) s))) + param))) (if remove-empty - (remove-if #'(lambda (x) (eq x :||)) keywords) - keywords))) + (remove-if #'(lambda (x) (eq x :||)) keywords) + keywords))) (defun html-quote (string) (regex-replace-all "([&<>])" string #'(lambda (target-string start end match-start &rest args) - (declare (ignore start end args)) - (ecase (elt target-string match-start) - (#\& "&") - (#\< "<") - (#\> ">"))))) + (declare (ignore start end args)) + (ecase (elt target-string match-start) + (#\& "&") + (#\< "<") + (#\> ">"))))) (defun parse-url () (values-list (cddr (mapcar #'url-decode (split "/" (script-name*)))))) @@ -119,16 +121,16 @@ (defun parse-date-field (name) (let ((timespec (mapcar #'(lambda (var) (parse-integer - (query-param (concatenate 'string name "-" var)) - :junk-allowed t)) - '("minute" "hour" "day" "month" "year")))) + (query-param (concatenate 'string name "-" var)) + :junk-allowed t)) + '("minute" "hour" "day" "month" "year")))) (unless (car timespec) (rplaca timespec 0)) (unless (cadr timespec) (rplaca (cdr timespec) 0)) (if (every #'identity timespec) - (apply #'encode-universal-time 0 timespec) - nil))) + (apply #'encode-universal-time 0 timespec) + nil))) (defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" @@ -137,7 +139,7 @@ (defun self-url (&key command prefix) (destructuring-bind - (empty old-prefix object-id &rest old-command) + (empty old-prefix object-id &rest old-command) (split "/" (script-name*)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))")) @@ -149,53 +151,53 @@ "Perform simple text to HTML conversion. http urls are replaced by links, internal links to images become image tags." (setf string (regex-replace-all - #?r"bknr:([0-9A-Za-z$-_.+!*'()]+)" string - #'(lambda (target-string start end match-start match-end reg-starts reg-ends) - (declare (ignore start end match-start match-end)) - (let ((url (subseq target-string (aref reg-starts 0) (aref reg-ends 0)))) - (regex-replace-all "URL" (if (all-matches "^/image" url) - "<img src=\"URL\" />" - "<a href=\"URL\">URL</a>") - url))))) + #?r"bknr:([0-9A-Za-z$-_.+!*'()]+)" string + #'(lambda (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (let ((url (subseq target-string (aref reg-starts 0) (aref reg-ends 0)))) + (regex-replace-all "URL" (if (all-matches "^/image" url) + "<img src=\"URL\" />" + "<a href=\"URL\">URL</a>") + url))))) (setf string (regex-replace-all - #?r"(http://[0-9A-Za-z$-_.+!*'()]+)" string - #'(lambda (target-string start end match-start match-end &rest args) - (declare (ignore start end args)) - (let ((url (subseq target-string match-start match-end))) - (regex-replace-all "URL" (if (all-matches "(?i)\\.(gif|jpe?g|png)$" url) - "<img src=\"URL\" />" - "<a href=\"URL\" target=\"_blank\">URL</a>") - url))))) + #?r"(http://[0-9A-Za-z$-_.+!*'()]+)" string + #'(lambda (target-string start end match-start match-end &rest args) + (declare (ignore start end args)) + (let ((url (subseq target-string match-start match-end))) + (regex-replace-all "URL" (if (all-matches "(?i)\\.(gif|jpe?g|png)$" url) + "<img src=\"URL\" />" + "<a href=\"URL\" target=\"_blank\">URL</a>") + url))))) (setf string (regex-replace-all "[\\r\\n]" string "<br>")) string) (defun make-wiki-hrefs (string) (regex-replace-all #?r"\[(.+?)\]" string - #'(lambda (target-string start end match-start match-end - reg-starts reg-ends) - (declare (ignore start end match-start match-end)) - (let ((keyword (subseq target-string - (svref reg-starts 0) - (svref reg-ends 0)))) - (format nil "<a class=\"wikilink\" href=\"/wiki/~a\">~a</a>" - keyword - keyword))))) + #'(lambda (target-string start end match-start match-end + reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (let ((keyword (subseq target-string + (svref reg-starts 0) + (svref reg-ends 0)))) + (format nil "<a class=\"wikilink\" href=\"/wiki/~a\">~a</a>" + keyword + keyword))))) (defmacro bknr-handler-case (body &rest handler-forms) `(if *bknr-debug* - ,body - (handler-case - ,body - ,@handler-forms))) + ,body + (handler-case + ,body + ,@handler-forms))) (defun emit-element-attributes (attributes) (loop for (key value) on attributes by #'cddr - do (progn - (princ " ") - (princ (string-downcase (symbol-name key))) - (princ "=\"") - (princ value) - (princ "\"")))) + do (progn + (princ " ") + (princ (string-downcase (symbol-name key))) + (princ "=\"") + (princ value) + (princ "\"")))) (defun emit-html (&rest forms) (let ((element (car forms))) @@ -205,7 +207,7 @@ ;; (:foo ...) or ((:foo ...) ...) (cons (if (consp (car element)) (handle-tag (caar element) (cdar element) (cdr element)) ; ((:foo ...) ...) - (handle-tag (car element) nil (cdr element)))) ; (:foo ...) + (handle-tag (car element) nil (cdr element)))) ; (:foo ...) ;; "foo" (string (princ element)))) (when (cdr forms) @@ -221,15 +223,15 @@ (when attributes (emit-element-attributes attributes)) (if body - ;; emit tag body - (progn - (princ ">") - (apply #'emit-html body) - (princ "</") - (princ tag-name) - (princ ">")) - ;; empty body, close tag immediately - (princ " />")))) + ;; emit tag body + (progn + (princ ">") + (apply #'emit-html body) + (princ "</") + (princ tag-name) + (princ ">")) + ;; empty body, close tag immediately + (princ " />")))) (defun encode-urlencoded (string) -(regex-replace-all #?r"\+" (url-encode string) "%20")) + (regex-replace-all #?r"\+" (url-encode string) "%20"))

1 0

[bknr-cvs] edi changed tags/thirdparty/flexi-streams-1.0.5/
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3718 Author: edi URL: http://bknr.net/trac/changeset/3718 Tag version 1.0.5 of flexi-streams A tags/thirdparty/flexi-streams-1.0.5/ Copied: tags/thirdparty/flexi-streams-1.0.5 (from rev 3717, trunk/thirdparty/flexi-streams)

1 0

[bknr-cvs] edi changed trunk/thirdparty/flexi-streams/
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3717 Author: edi URL: http://bknr.net/trac/changeset/3717 Update to 1.0.5 U trunk/thirdparty/flexi-streams/CHANGELOG U trunk/thirdparty/flexi-streams/doc/index.html U trunk/thirdparty/flexi-streams/flexi-streams.asd U trunk/thirdparty/flexi-streams/test/packages.lisp Modified: trunk/thirdparty/flexi-streams/CHANGELOG =================================================================== --- trunk/thirdparty/flexi-streams/CHANGELOG 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/CHANGELOG 2008-08-01 10:14:17 UTC (rev 3717) @@ -1,3 +1,7 @@ +Version 1.0.5 +2008-08-01 +Export RUN-ALL-TESTS instead of RUN-TESTS (caught by Nick Allen) + Version 1.0.4 2008-07-25 Cosmetic surgery on test suite Modified: trunk/thirdparty/flexi-streams/doc/index.html =================================================================== --- trunk/thirdparty/flexi-streams/doc/index.html 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/doc/index.html 2008-08-01 10:14:17 UTC (rev 3717) @@ -229,7 +229,7 @@ <p> FLEXI-STREAMS together with this documentation can be downloaded from <a href="http://weitz.de/files/flexi-streams.tar.gz">http://weitz.de/files/flexi-streams.tar.gz</a>. The -current version is 1.0.4. +current version is 1.0.5. <p> Before you install FLEXI-STREAMS you first need to install the <a @@ -1114,7 +1114,7 @@ his work on making FLEXI-STREAMS faster. <p> -$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.123 2008/07/25 09:57:00 edi Exp $ +$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.124 2008/08/01 10:12:41 edi Exp $ <p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body> Modified: trunk/thirdparty/flexi-streams/flexi-streams.asd =================================================================== --- trunk/thirdparty/flexi-streams/flexi-streams.asd 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/flexi-streams.asd 2008-08-01 10:14:17 UTC (rev 3717) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.76 2008/07/25 09:56:58 edi Exp $ +;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.77 2008/08/01 10:12:40 edi Exp $ ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved. @@ -35,7 +35,7 @@ (in-package :flexi-streams-system) (defsystem :flexi-streams - :version "1.0.4" + :version "1.0.5" :serial t :components ((:file "packages") (:file "mapping") Modified: trunk/thirdparty/flexi-streams/test/packages.lisp =================================================================== --- trunk/thirdparty/flexi-streams/test/packages.lisp 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/test/packages.lisp 2008-08-01 10:14:17 UTC (rev 3717) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/flexi-streams/test/packages.lisp,v 1.6 2008/05/17 16:38:26 edi Exp $ +;;; $Header: /usr/local/cvsrep/flexi-streams/test/packages.lisp,v 1.8 2008/08/01 10:12:43 edi Exp $ ;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. @@ -36,4 +36,4 @@ :with-rebinding :char* :normalize-external-format) - (:export :run-tests)) + (:export :run-all-tests))

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3716 Author: hans URL: http://bknr.net/trac/changeset/3716 more news work. make owned-object have only one instead of multiple owners. U trunk/bknr/modules/album/album.lisp U trunk/bknr/web/src/images/image.lisp U trunk/bknr/web/src/packages.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/bknr/web/src/sysclasses/user.lisp U trunk/projects/quickhoney/src/handlers.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/website/static/javascript.js Modified: trunk/bknr/modules/album/album.lisp =================================================================== --- trunk/bknr/modules/album/album.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/modules/album/album.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -6,7 +6,7 @@ (let* ((user (find-user username)) (images (when user (remove-if-not #'(lambda (image) - (member user (owned-object-owners image))) + (eq user (owned-object-owner image))) (get-keyword-store-images (make-keyword-from-string album)))))) (html (:ul (dolist (image images) Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/images/image.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -123,7 +123,7 @@ ;; xxx not tx safe. (let ((store-image (apply #'make-object class-name - :owners (list user) + :owner user :timestamp (get-universal-time) :name name :type (make-keyword-from-string type) Modified: trunk/bknr/web/src/packages.lisp =================================================================== --- trunk/bknr/web/src/packages.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/packages.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -136,7 +136,7 @@ #:set-user-last-login #:owned-object - #:owned-object-owners + #:owned-object-owner #:store-objects-owned-by #:store-object-owners Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/rss/rss.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -179,7 +179,7 @@ (:documentation "Add ITEM to CHANNEL. May only be called within transaction context.") (:method ((channel rss-channel) item) - (setf (slot-value channel 'items) (cons item (rss-channel-items channel)))) + (push item (slot-value channel 'items))) (:method ((channel string) item) (aif (find-rss-channel channel) (add-item it item) Modified: trunk/bknr/web/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/web/src/sysclasses/user.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -190,24 +190,23 @@ ;;; owned objects (define-persistent-class owned-object (store-object) - ((owners :update :initform nil - :index-type hash-list-index - :index-reader store-object-owners))) + ((owner :update :initform nil + :index-type hash-index + :index-reader store-object-owner))) -(deftransaction owned-object-remove-owner (object owner) - (setf (owned-object-owners object) - (remove owner (owned-object-owners object)))) +(defmethod convert-slot-value-while-restoring ((object owned-object) (slot-name (eql 'owners)) owners) + (when owners + (unless (= 1 (length owners)) + (warn "object ~A has more than one owner ~S, using first" object owners)) + (setf (slot-value object 'owner) (car owners)))) -(deftransaction owned-object-add-owner (object owner) - (pushnew owner (owned-object-owners object))) - (defgeneric user-owns-object-p (user object)) -(defmethod user-owns-object-p ((user user) object) +(defmethod user-owns-object-p ((user user) (object t)) nil) (defmethod user-owns-object-p ((user user) (object owned-object)) - (member user (owned-object-owners object))) + (eq user (owned-object-owner object))) (define-persistent-class message-event (event) ((from :read :initform nil) Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -136,7 +136,7 @@ (cl-smtp:with-smtp-mail (smtp "localhost" "webserver(a)quickhoney.com" (remove-duplicates (mapcar #'user-email - (or (owned-object-owners image) + (or (owned-object-owner image) (list (find-user "n") (find-user "p")))))) (cl-mime:print-mime smtp @@ -438,13 +438,18 @@ (:method ((item t)) ; do nothing ) + (:method :before ((image quickhoney-image)) + (when (owned-object-owner image) + (encode-object-element "owner" (user-login (owned-object-owner image)))) + (encode-object-element "date" (format-date-time (blob-timestamp image) :vms-style t :show-time nil)) + (encode-object-element "name" (store-image-name image))) (:method ((image quickhoney-image)) (let ((vectorp (member :vector (store-image-keywords image)))) - (encode-object-element "uploader" (if vectorp "Peter" "Nana")) (encode-object-element "category" (if vectorp "vector" "pixel")) - (encode-object-element "subcategory" "unknown") - (encode-object-element "date" (format-date-time (rss-item-pub-date image) :vms-style t :show-time nil)) - (encode-object-element "name" (store-image-name image))))) + (encode-object-element "subcategory" "unknown"))) + (:method ((item quickhoney-news-item)) + (encode-object-element "title" (quickhoney-news-item-title item)) + (encode-object-element "text" (quickhoney-news-item-text item)))) (defmethod handle-object ((handler json-news-handler) (channel rss-channel)) (with-json-response () Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-08-01 06:57:30 UTC (rev 3716) @@ -33,7 +33,7 @@ (:file "layout" :depends-on ("config")) (:file "imageproc" :depends-on ("config")) (:file "json" :depends-on ("packages")) - (:file "handlers" :depends-on ("json" "layout" "config" "image")) + (:file "handlers" :depends-on ("json" "layout" "config" "image" "news")) (:file "tags" :depends-on ("image")) (:file "webserver" :depends-on ("handlers")) (:file "daily" :depends-on ("config")) Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-08-01 06:57:30 UTC (rev 3716) @@ -246,7 +246,7 @@ IMG({ src: "/image/" + item.name + '/cutout-button,,' + color + ',98,4'}), DIV(null, H1(null, item.name), - item.date, ' by ', item.uploader, ' | ', + item.date, ' by ', item.owner, ' | ', A({ href: '/index#' + item.category + '/' + item.subcategory + '/' + item.image_name }, 'permalink'), BR(), item.description)), @@ -461,7 +461,7 @@ function() { footer_hide(); loadJSONDoc('/json-news-archive/quickhoney').addCallbacks(load_news_archive, alert); - // load_news(); + loadJSONDoc('/json-news/quickhoney').addCallbacks(load_news, alert); }); pages['shop']

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/packages.lisp
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3715 Author: hans URL: http://bknr.net/trac/changeset/3715 Don't export *CATCH-ERRORS-P* anymore. U trunk/thirdparty/hunchentoot/packages.lisp Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2008-08-01 04:41:26 UTC (rev 3714) +++ trunk/thirdparty/hunchentoot/packages.lisp 2008-08-01 06:19:07 UTC (rev 3715) @@ -39,7 +39,6 @@ #+:lispworks (:import-from :lw "WITH-UNIQUE-NAMES" "WHEN-LET") (:export "*APPROVED-RETURN-CODES*" - "*CATCH-ERRORS-P*" #+:lispworks "*CLEANUP-FUNCTION*" #+:lispworks

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/json.lisp
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3714 Author: hans URL: http://bknr.net/trac/changeset/3714 Re-rename stream->output-stream U trunk/projects/quickhoney/src/json.lisp Modified: trunk/projects/quickhoney/src/json.lisp =================================================================== --- trunk/projects/quickhoney/src/json.lisp 2008-07-31 22:25:05 UTC (rev 3713) +++ trunk/projects/quickhoney/src/json.lisp 2008-08-01 04:41:26 UTC (rev 3714) @@ -3,18 +3,18 @@ (defvar *json-output*) (defclass json-output-stream () - ((stream :reader stream - :initarg :stream) + ((output-stream :reader output-stream + :initarg :output-stream) (stack :accessor stack :initform nil))) (defun next-aggregate-element () (if (car (stack *json-output*)) - (princ (car (stack *json-output*)) (stream *json-output*)) + (princ (car (stack *json-output*)) (output-stream *json-output*)) (setf (car (stack *json-output*)) #\,))) (defmacro with-json-output ((stream) &body body) - `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) + `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream))) ,@body)) (defmacro with-json-output-to-string (() &body body) @@ -26,12 +26,12 @@ `(progn (when (stack *json-output*) (next-aggregate-element)) - (princ ,begin-char (stream *json-output*)) + (princ ,begin-char (output-stream *json-output*)) (push nil (stack *json-output*)) (prog1 (progn ,@body) (pop (stack *json-output*)) - (princ ,end-char (stream *json-output*))))) + (princ ,end-char (output-stream *json-output*))))) (defmacro with-json-array (() &body body) `(with-json-aggregate (#\[ #\]) @@ -43,18 +43,18 @@ (defun encode-array-element (object) (next-aggregate-element) - (json:encode-json object (stream *json-output*))) + (json:encode-json object (output-stream *json-output*))) (defun encode-object-element (key value) (next-aggregate-element) - (json:encode-json key (stream *json-output*)) - (princ #\: (stream *json-output*)) - (json:encode-json value (stream *json-output*))) + (json:encode-json key (output-stream *json-output*)) + (princ #\: (output-stream *json-output*)) + (json:encode-json value (output-stream *json-output*))) (defmacro with-object-element ((key) &body body) `(progn (next-aggregate-element) - (json:encode-json ,key (stream *json-output*)) + (json:encode-json ,key (output-stream *json-output*)) (setf (car (stack *json-output*)) #\:) (unwind-protect (progn ,@body) @@ -62,6 +62,6 @@ (defmacro with-json-response (() &body body) `(with-http-response (:content-type "application/json") - (with-json-output-to-string () - (with-json-object () - ,@body)))) + (with-json-output-to-string () + (with-json-object () + ,@body))))

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3713 Author: hans URL: http://bknr.net/trac/changeset/3713 News start working. U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/handlers.lisp A trunk/projects/quickhoney/src/json.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/src/webserver.lisp U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -121,35 +121,37 @@ (when (boundp 'hunchentoot:*request*) (let ((month-string (bknr.web:query-param "month"))) (when month-string - (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=..))" month-string :limit 2)))))) + (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=....))" month-string :limit 2)))))) (defun rss-channel-archive (channel) "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" - (group-on (rss-channel-items channel) + (group-on (rss-channel-items channel :all t) :test #'equal :key (lambda (item) (multiple-value-bind (seconds minutes hours day month year) (decode-universal-time (rss-item-pub-date item)) (declare (ignore seconds minutes hours day)) - (list month year))))) + (list year month))))) (defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (:method ((channel rss-channel) &key days month count) + (:method ((channel rss-channel) &key days month count all) (unless month (setf month (month-from-query-parameter))) (unless days (setf days (or (days-from-query-parameter) (rss-channel-max-item-age channel)))) - (let ((items (if month - (cdr (find month (rss-channel-archive channel) :test #'equal)) - (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items)))))) - (if count - (subseq items 0 (min count (length items))) - items)))) + (if all + (remove-if #'object-destroyed-p (slot-value channel 'items)) + (let ((items (if month + (cdr (find month (rss-channel-archive channel) :test #'equal :key #'car)) + (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))) + (if count + (subseq items 0 (min count (length items))) + items))))) (defgeneric rss-channel-archived-months (channel) (:documentation "Return a list of lists (MONTH YEAR) for which the Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -426,67 +426,46 @@ (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (:p ((:a :href "javascript:window.close()") "ok")))))))))))) -(defclass news-json-handler (object-handler) +(defclass rss-channel-handler (object-handler) () (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel)) -(defvar *json-output*) +(defclass json-news-handler (rss-channel-handler) + ()) -(defclass json-output-stream () - ((output-stream :reader output-stream - :initarg :output-stream) - (stack :accessor stack - :initform nil))) -(defun next-aggregate-element () - (if (car (stack *json-output*)) - (princ #\, (output-stream *json-output*)) - (setf (car (stack *json-output*)) t))) +(defgeneric json-encode-news-item (item) + (:method ((item t)) + ; do nothing + ) + (:method ((image quickhoney-image)) + (let ((vectorp (member :vector (store-image-keywords image)))) + (encode-object-element "uploader" (if vectorp "Peter" "Nana")) + (encode-object-element "category" (if vectorp "vector" "pixel")) + (encode-object-element "subcategory" "unknown") + (encode-object-element "date" (format-date-time (rss-item-pub-date image) :vms-style t :show-time nil)) + (encode-object-element "name" (store-image-name image))))) -(defmacro with-json-output ((stream) &body body) - `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream))) - ,@body)) - -(defmacro with-json-output-to-string (() &body body) - `(with-output-to-string (s) - (with-json-output (s) - ,@body))) - -(defmacro with-json-aggregate ((begin-char end-char) &body body) - `(progn - (when (stack *json-output*) - (next-aggregate-element)) - (princ ,begin-char (output-stream *json-output*)) - (push nil (stack *json-output*)) - (prog1 - (progn ,@body) - (pop (stack *json-output*)) - (princ ,end-char (output-stream *json-output*))))) - -(defmacro with-json-array (() &body body) - `(with-json-aggregate (#\[ #\]) - ,@body)) - -(defmacro with-json-object (() &body body) - `(with-json-aggregate (#\{ #\}) - ,@body)) - -(defun encode-array-element (object) - (next-aggregate-element) - (json:encode-json object (output-stream *json-output*))) - -(defun encode-object-element (key value) - (next-aggregate-element) - (json:encode-json key (output-stream *json-output*)) - (princ #\: (output-stream *json-output*)) - (json:encode-json value (output-stream *json-output*))) - -(defmethod handle-object ((handler news-json-handler) (channel rss-channel)) - (with-http-response (:content-type "application/json") - (with-json-output-to-string () +(defmethod handle-object ((handler json-news-handler) (channel rss-channel)) + (with-json-response () + (with-object-element ("items") (with-json-array () (dolist (item (rss-channel-items channel)) (with-json-object () - (encode-object-element "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) - (encode-object-element "title" (rss-item-title item)) - (encode-object-element "description" (rss-item-description item)))))))) + (json-encode-news-item item))))))) + +(defclass json-news-archive-handler (rss-channel-handler) + ()) + +(defmethod handle-object ((handler json-news-archive-handler) (channel rss-channel)) + (with-json-response () + (with-object-element ("months") + (with-json-array () + (dolist (month (sort (rss-channel-archived-months channel) + (lambda (a b) + (if (= (first a) (first b)) + (> (second a) (second b)) + (> (first a) (first b)))))) + (with-json-array () + (encode-array-element (first month)) + (encode-array-element (second month)))))))) \ No newline at end of file Added: trunk/projects/quickhoney/src/json.lisp =================================================================== --- trunk/projects/quickhoney/src/json.lisp (rev 0) +++ trunk/projects/quickhoney/src/json.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -0,0 +1,67 @@ +(in-package :quickhoney) + +(defvar *json-output*) + +(defclass json-output-stream () + ((stream :reader stream + :initarg :stream) + (stack :accessor stack + :initform nil))) + +(defun next-aggregate-element () + (if (car (stack *json-output*)) + (princ (car (stack *json-output*)) (stream *json-output*)) + (setf (car (stack *json-output*)) #\,))) + +(defmacro with-json-output ((stream) &body body) + `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) + ,@body)) + +(defmacro with-json-output-to-string (() &body body) + `(with-output-to-string (s) + (with-json-output (s) + ,@body))) + +(defmacro with-json-aggregate ((begin-char end-char) &body body) + `(progn + (when (stack *json-output*) + (next-aggregate-element)) + (princ ,begin-char (stream *json-output*)) + (push nil (stack *json-output*)) + (prog1 + (progn ,@body) + (pop (stack *json-output*)) + (princ ,end-char (stream *json-output*))))) + +(defmacro with-json-array (() &body body) + `(with-json-aggregate (#\[ #\]) + ,@body)) + +(defmacro with-json-object (() &body body) + `(with-json-aggregate (#\{ #\}) + ,@body)) + +(defun encode-array-element (object) + (next-aggregate-element) + (json:encode-json object (stream *json-output*))) + +(defun encode-object-element (key value) + (next-aggregate-element) + (json:encode-json key (stream *json-output*)) + (princ #\: (stream *json-output*)) + (json:encode-json value (stream *json-output*))) + +(defmacro with-object-element ((key) &body body) + `(progn + (next-aggregate-element) + (json:encode-json ,key (stream *json-output*)) + (setf (car (stack *json-output*)) #\:) + (unwind-protect + (progn ,@body) + (setf (car (stack *json-output*)) #\,)))) + +(defmacro with-json-response (() &body body) + `(with-http-response (:content-type "application/json") + (with-json-output-to-string () + (with-json-object () + ,@body)))) Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-07-31 22:25:05 UTC (rev 3713) @@ -32,7 +32,8 @@ (:file "news" :depends-on ("image")) (:file "layout" :depends-on ("config")) (:file "imageproc" :depends-on ("config")) - (:file "handlers" :depends-on ("layout" "config" "image")) + (:file "json" :depends-on ("packages")) + (:file "handlers" :depends-on ("json" "layout" "config" "image")) (:file "tags" :depends-on ("image")) (:file "webserver" :depends-on ("handlers")) (:file "daily" :depends-on ("config")) Modified: trunk/projects/quickhoney/src/webserver.lisp =================================================================== --- trunk/projects/quickhoney/src/webserver.lisp 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/src/webserver.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -33,7 +33,8 @@ ("/admin" admin-handler) ("/upload-news" upload-news-handler) ("/digg-image" digg-image-handler) - ("/news-json" news-json-handler) + ("/json-news-archive" json-news-archive-handler) + ("/json-news" json-news-handler) ("/" template-handler :default-template "frontpage" :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-31 22:25:05 UTC (rev 3713) @@ -215,11 +215,80 @@ /* news */ -function load_news() +var month_names = [ 'January', 'February', 'March', 'April', 'May', 'June', + 'July', 'August', 'September', 'October', 'November', 'December' ]; + +function select_archive_year() { - + var year = this.href.match(/#news\/(\d+)/)[1]; + map(function (element) { + if (element.href) { + ((element.href.match(/#news\/(\d+)/)[1] == year) ? addElementClass : removeElementClass)(element, 'active'); + } + }, this.parentNode.childNodes); + return true; } +function select_archive_month() +{ + var month = this.href.match(/#news\/(\d+\/\d+)/)[1]; + loadJSONDoc('/json-news/quickhoney?month=' + month).addCallbacks(load_news, alert); + return true; +} + +function load_news(data) +{ + log('load news: ' + data.items.length); + replaceChildNodes('newsentries', + map(function (item) { + var color = (item.category == 'pixel') ? 'ff00ff' : '00ccff'; + return [ DIV({ 'class': 'newsentry autonews news_' + item.category }, + IMG({ src: "/image/" + item.name + '/cutout-button,,' + color + ',98,4'}), + DIV(null, + H1(null, item.name), + item.date, ' by ', item.uploader, ' | ', + A({ href: '/index#' + item.category + '/' + item.subcategory + '/' + item.image_name }, 'permalink'), + BR(), + item.description)), + DIV({ 'class': 'news_sep' }) ]; + }, data.items)); +} + +function load_news_archive(data) +{ + try { + if (!data.months) { + alert('no archive data found'); + } + var currentYear; + var active = true; + replaceChildNodes('archive-navigation', + SPAN({ 'class': 'title' }, 'Archive'), BR(), + map(function (entry) { + var year = entry[0]; + var month = entry[1]; + var result = []; + if (year != currentYear) { + if (currentYear) { + active = false; + } + currentYear = year; + var link = A({ href: '#news/' + year, 'class': 'year' }, year, BR()); + link.onclick = select_archive_year; + result.push(link); + } + var link = A({ href: '#news/' + year + '/' + month, 'class': 'month ' + (active ? ' active' : '')}, + month_names[month - 1], BR()); + link.onclick = select_archive_month; + result.push(link); + return result; + }, data.months)); + } + catch (e) { + log('error while processing archive data: ' + e); + } +} + /* image database */ var current_directory; @@ -391,7 +460,8 @@ '30be01', function() { footer_hide(); - load_news(); + loadJSONDoc('/json-news-archive/quickhoney').addCallbacks(load_news_archive, alert); + // load_news(); }); pages['shop'] Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-31 22:25:05 UTC (rev 3713) @@ -627,4 +627,9 @@ top: 0px; left: 585px; visibility: hidden; -} \ No newline at end of file +} + +.archive span.title, .archive a.year { font-size: 1.5em; } +.archive a.month.active { display: block; } +.archive a.month { display: none; } +.archive { padding-left: 1em; } \ No newline at end of file Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-31 22:25:05 UTC (rev 3713) @@ -130,25 +130,33 @@ </div> <div id="news_page"> - <p id="news_content"> - <div class="newsentry news_vector autonews"> - <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> - <div> - <h1>Jan and Ella</h1> - March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> - description - </div> - </div> - <div class="news_sep"> </div> - <br/> - <div class="newsentry news_pixel autonews"> - <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> - <div> - March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> - description - </div> - </div> - </p> + <table border="0"> + <tbody> + <tr> + <td valign="top" id="newsentries"> + <div class="newsentry news_vector autonews"> + <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> + <div> + <h1>Jan and Ella</h1> + March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> + description + </div> + </div> + <div class="news_sep"> </div> + <br/> + <div class="newsentry news_pixel autonews"> + <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> + <div> + March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> + description + </div> + </div> + </td> + <td class="archive" id="archive-navigation" valign="top"> + </td> + </tr> + </tbody> + </table> </div> <div id="cart_page">

1 0

[bknr-cvs] ksprotte changed trunk/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3712 Author: ksprotte URL: http://bknr.net/trac/changeset/3712 xhtmlgen: should have left :canonical nil untouched U trunk/projects/bos/web/cms-links.lisp U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/webserver.lisp U trunk/xhtmlgen/xhtmlgen.lisp Modified: trunk/projects/bos/web/cms-links.lisp =================================================================== --- trunk/projects/bos/web/cms-links.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/projects/bos/web/cms-links.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -29,12 +29,9 @@ (cmslink (edit-object-url poi) (:princ (format nil "edit ~a" (poi-name poi))))) -(defmethod object-url ((poi-image poi-image)) - (format nil "/poi-image/~A" (store-object-id poi-image))) +(defmethod edit-object-url ((medium poi-medium)) + (format nil "/edit-poi-medium/~a" (store-object-id medium))) -(defmethod edit-object-url ((poi-image poi-image)) - (format nil "/edit-poi-image/~a" (store-object-id poi-image))) - (defmethod html-link ((poi-image poi-image)) (cmslink (object-url poi-image) (:princ (store-object-id poi-image)))) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -64,7 +64,7 @@ (content-language-chooser) (unless (poi-complete poi language) (html (:h2 "This POI is not complete in the current language - Please check that " - "the location and all text fields are set and that at least one image " + "the location and all text fields are set and that at least 6 images " "has been uploaded."))) ((:form :method "POST" :enctype "multipart/form-data") ((:table :border "1") @@ -98,13 +98,13 @@ "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) - (:tr (:td "images") + (:tr (:td "sat images") (:td ((:table) (:tr (loop for image in (poi-sat-images poi) for index upfrom 0 - do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) + do (html (:td ((:a :href (format nil "/edit-poi-medium/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) :br (if (zerop index) @@ -119,57 +119,31 @@ (store-object-id poi) index (store-object-id image))) ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) - (unless (eql 6 (length (poi-sat-images poi))) + (unless (= 6 (length (poi-sat-images poi))) (html :br - (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) - (:tr (:td "airal view" - ((:input :id "airal-id" :type "hidden" :name "airal-id"))) - (:td (:table (dolist (airal (poi-airals poi)) - (html (:tr (:td ((:a :href (format nil "/image/~D" (store-object-id airal)) - :target "_new") - ((:img :src (format nil "/image/~D" (store-object-id airal)) - :width "90" :height "90")))) - (:td (submit-button "delete-airal" "delete-airal" - :formcheck #?"javascript:confirm_delete('airal-id', $((store-object-id airal)), 'Really delete the airal?')"))))) - (:tr ((:td :colspan "2") - "Upload new airal view" - ((:input :type "file" :name "image-file")) - :br - (submit-button "upload-airal" "upload-airal")))))) - (:tr (:td "panorama view" - ((:input :id "panorama-id" :type "hidden" :name "panorama-id"))) - (:td (dolist (panorama (poi-panoramas poi)) - (html (:princ-safe (format-date-time (blob-timestamp panorama))) - ((:a :href (format nil "/image/~D" (store-object-id panorama)) :target "_new" :class "cmslink") - " view ") - (submit-button "delete-panorama" "delete-panorama" - :formcheck #?"javascript:confirm_delete('panorama-id', $((store-object-id panorama)), 'Really delete this panorama image?')") - :br)) - (html "Upload new panorama view" - ((:input :type "file" :name "image-file")) - :br - (submit-button "upload-panorama" "upload-panorama")))) - (:tr (:td "movies" - ((:input :id "movie-id" :type "hidden" :name "movie-id"))) - (:td (dolist (movie (poi-movies poi)) - (html (:princ-safe (format-date-time (store-object-last-change movie 0))) - ((:a :href (format nil "/poi-movie/~D" (store-object-id movie)) :target "_new" :class "cmslink") - " view ") - (submit-button "delete-movie" "delete-movie" - :formcheck #?"javascript:confirm_delete('movie-id', $((store-object-id movie)), 'Really delete this movie?')") - :br)) - (html "URL or 'embed' string: " - ((:input :type "text" - :size "50" - :name "movie-url" - :id "movie" - :value "" - :onchange "parse_youtube_link(this)")) - :br - (submit-button "add-movie" "add-movie")))) + (cmslink (format nil "edit-poi-medium/?poi=~A" (store-object-id poi)) "[new]"))))) (:tr (:td (submit-button "save" "save") - (submit-button "delete" "delete" :confirm "Really delete the POI?")))))))) + (submit-button "delete" "delete" :confirm "Really delete the POI?")))) + ;; ;;;;;;;;;;;;;;;; + (:h2 "Upload new medium") + ((:form :method "post" :action "/edit-poi-medium" :enctype "multipart/form-data") + (:table (:tr (:td "Type") + (:td (select-box "medium-type" (mapcar #'(lambda (class-name) (string-downcase (symbol-name class-name))) + (class-subclasses (find-class 'poi-medium))) + :default "poi-image"))) + (:tr + (:td "File") + (:td ((:input :type "file" :name "image-file"))) + (:tr ((:td :colspan "2") (submit-button "upload" "upload")))))) + (:h2 "Attached POI media") + ((:table :border "1") + (dolist (medium (poi-media poi)) + (html (:tr (:td (:princ-safe (medium-pretty-type-string medium))) + (:td (:table (medium-handler-preview medium :small t) + (:tr (:td) + (:td (cmslink (format nil "/edit-poi-medium/~D?poi=~D" + (store-object-id medium) (store-object-id poi)) "edit"))))))))))))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :save)) (poi poi)) @@ -278,6 +252,114 @@ (html (:h2 "POI has been deleted") "The POI has been deleted"))) + +;;; edit-poi-medium-handler +(defclass edit-poi-medium-handler (editor-only-handler edit-object-handler) + () + (:default-initargs :object-class 'poi-medium)) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) action (medium poi-medium)) + (with-query-params (language poi) + (unless language (setq language (request-language))) + (with-bos-cms-page (:title (format nil "Edit ~A" (medium-pretty-type-string medium))) + (html + (cmslink (edit-object-url (poi-medium-poi medium)) "Back to POI") + (content-language-chooser) + ((:form :method "post" :enctype "multipart/form-data") + ((:input :type "hidden" :name "poi" :value poi)) + (:table (medium-handler-preview medium) + (:tr ((:td :colspan "2" :height "10"))) + (:tr (:td "upload new image") + (:td ((:input :type "file" :name "image-file")) + :br + (submit-button "upload" "upload"))) + (:tr ((:td :colspan "2" :height "10"))) + (:tr (:td "title") + (:td (text-field "title" + :value (slot-string medium 'title language)))) + (:tr (:td "subtitle") + (:td (text-field "subtitle" + :value (slot-string medium 'subtitle language)))) + (:tr (:td "description") + (:td (textarea-field "description" + :value (slot-string medium 'description language) + :rows 5 + :cols 40))) + (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete?"))))))))) + +(defgeneric medium-pretty-type-string (medium) + (:method ((medium poi-image)) "POI Image") + (:method ((medium poi-panorama)) "POI Panorama") + (:method ((medium poi-airal)) "POI Airal") + (:method ((medium poi-movie)) "POI Movie")) + +(defgeneric medium-handler-preview (medium &key small) + (:method ((medium t) &key small) + (declare (ignore small)) + (html ((:tr :colspan "2") "No preview"))) + (:method ((medium poi-image) &key small) + (html + (:tr (:td "thumbnail") + (:td ((:img :src (format nil "/image/~A/thumbnail,,55,55" (store-object-id medium)))))) + (unless small + (html + (:tr (:td "full image") + (:td ((:img :src (format nil "/image/~A" (store-object-id medium)))))))))) + (:method ((medium poi-panorama) &key small) + (declare (ignore small)) + (html + (:tr (:td "thumbnail") + (:td ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium))))))))) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :save)) (medium poi-medium)) + (with-query-params (title subtitle description language) + (unless language (setq language (request-language))) + (update-textual-attributes medium language + :title title + :subtitle subtitle + :description description) + (let ((type-string (medium-pretty-type-string medium))) + (with-bos-cms-page (:title (format nil "~A has been updated" type-string)) + (:h2 (format nil "The ~A information has been updated" type-string)) + "You may " (cmslink (format nil "~A?language=~A" (edit-object-url medium) language) + (:princ-safe (format nil "continue editing the ~A" type-string))))))) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :delete)) (medium poi-medium)) + (let ((poi (poi-medium-poi medium)) + (type-string (medium-pretty-type-string medium))) + (delete-object medium) + (with-bos-cms-page (:title (format nil "~A has been deleted" type-string)) + (:h2 (format nil "The ~A has been deleted" type-string)) + "You may " (cmslink (edit-object-url poi) "continue editing the POI")))) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :upload)) medium) + (with-query-params (poi) + (setq poi (find-store-object (parse-integer poi) :class 'poi)) + (let ((upload (request-uploaded-file "image-file"))) + (unless upload + (error "no file uploaded in upload handler")) + (bknr.web:with-image-from-upload* (upload) + (unless (and (eql (cl-gd:image-width) *poi-image-width*) + (eql (cl-gd:image-height) *poi-image-height*)) + (with-bos-cms-page (:title "Invalid image size") + (:h2 "Invalid image size") + (:p "The image needs to be " + (:princ-safe *poi-image-width*) " pixels wide and " + (:princ-safe *poi-image-height*) " pixels high. Your uploaded image is " + (:princ-safe (cl-gd:image-width)) " pixels wide and " + (:princ-safe (cl-gd:image-height)) " pixels high. Please use an image editor " + "to resize the image and upload it again.") + (:p (cmslink (edit-object-url poi) "Back to POI"))) + (return-from handle-object-form t))) + (let ((new-medium (import-image upload + :class-name (type-of medium) + :initargs `(:poi ,poi)))) + (when medium + (delete-object medium)) + (redirect (format nil "/edit-poi-medium/~D?poi=~D" + (store-object-id new-medium) + (store-object-id poi))))))) + ;;; edit-poi-image-handler (defclass edit-poi-image-handler (editor-only-handler edit-object-handler) () Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/projects/bos/web/webserver.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -157,6 +157,7 @@ (make-instance 'bos-website :name "create-rainforest.org CMS" :handler-definitions `(("/edit-poi-image" edit-poi-image-handler) + ("/edit-poi-medium" edit-poi-medium-handler) ("/edit-poi" edit-poi-handler) ("/edit-sponsor" edit-sponsor-handler) ("/kml-upload" kml-upload-handler) Modified: trunk/xhtmlgen/xhtmlgen.lisp =================================================================== --- trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -51,12 +51,12 @@ ,(process-html-forms forms env))) (if (boundp '*html-sink*) (,body) - (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical t))) + (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil))) (,body) (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil))) ,(process-html-forms forms env) (sax:end-document *html-sink*))) @@ -64,7 +64,7 @@ (declare (ignore indentation)) (when indentation-given (warn "WITH-XHTML: indentation argument is deprecated. It will be ignored")) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil))) (sax:start-document *html-sink*) (sax:start-dtd *html-sink* "html"

1 0

[bknr-cvs] ksprotte changed trunk/xhtmlgen/xhtmlgen.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3711 Author: ksprotte URL: http://bknr.net/trac/changeset/3711 xhtmlgen does not indent anymore U trunk/xhtmlgen/xhtmlgen.lisp Modified: trunk/xhtmlgen/xhtmlgen.lisp =================================================================== --- trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 15:57:09 UTC (rev 3710) +++ trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 16:16:24 UTC (rev 3711) @@ -48,28 +48,31 @@ ;; just emit html to the current stream (let ((body (gensym))) `(labels ((,body () - ,(process-html-forms forms env))) - (if (boundp '*html-sink*) - (,body) - (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3))) - (,body) - (sax:end-document *html-sink*)))))) + ,(process-html-forms forms env))) + (if (boundp '*html-sink*) + (,body) + (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical t))) + (,body) + (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3))) - ,(process-html-forms forms env) - (sax:end-document *html-sink*))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + ,(process-html-forms forms env) + (sax:end-document *html-sink*))) -(defmacro with-xhtml ((&optional stream &key (indentation 3)) &body body) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation ,indentation))) - (sax:start-document *html-sink*) - (sax:start-dtd *html-sink* - "html" - "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") - (sax:end-dtd *html-sink*) - (multiple-value-prog1 - (html +(defmacro with-xhtml ((&optional stream &key (indentation 3 indentation-given)) &body body) + (declare (ignore indentation)) + (when indentation-given + (warn "WITH-XHTML: indentation argument is deprecated. It will be ignored")) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + (sax:start-document *html-sink*) + (sax:start-dtd *html-sink* + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd *html-sink*) + (multiple-value-prog1 + (html ,@body) (sax:end-document *html-sink*))))

1 0