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

[bknr-cvs] r2512 - branches/trunk-reorg/thirdparty/uffi-1.6.0/tests
by hhubner＠common-lisp.net 16 Feb '08

16 Feb '08

Author: hhubner Date: Sat Feb 16 07:43:24 2008 New Revision: 2512 Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp Log: Add unit test that verifies pointer-to-pointer structure fields. Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp (original) +++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp Sat Feb 16 07:43:24 2008 @@ -19,7 +19,8 @@ (uffi:def-struct foo - (bar :pointer-self)) + (bar :pointer-self) + (pointer-pointer (* (* :unsigned-char)))) (uffi:def-foreign-type foo-ptr (* foo))

1 0

[bknr-cvs] r2511 - branches/bos/projects/bos
by ksprotte＠common-lisp.net 16 Feb '08

16 Feb '08

Author: ksprotte Date: Sat Feb 16 07:40:30 2008 New Revision: 2511 Modified: branches/bos/projects/bos/Makefile Log: bos make cleanall use rm -f Modified: branches/bos/projects/bos/Makefile ============================================================================== --- branches/bos/projects/bos/Makefile (original) +++ branches/bos/projects/bos/Makefile Sat Feb 16 07:40:30 2008 @@ -26,7 +26,7 @@ .PHONY: cleanfasl cleanfasl: - (cd ../.. && find . -name '*.x86f' | xargs rm) + (cd ../.. && find . -name '*.x86f' | xargs rm -f) .PHONY: cleanall cleanall: cleancore cleanfasl

1 0

[bknr-cvs] r2510 - in branches/trunk-reorg: bknr/web/src/web projects/quickhoney/website/static xhtmlgen
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 16:22:21 2008 New Revision: 2510 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp branches/trunk-reorg/projects/quickhoney/website/static/styles.css branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: More xhtmlgen fixes. Make error handling work again. Errors are displayed to the user unless *catch-errors-p* is true. Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Fri Feb 15 16:22:21 2008 @@ -233,15 +233,16 @@ (redirect-uri (parse-uri (script-name)))) (redirect (website-make-path *website* "login"))) (if *catch-errors-p* - (handle handler) - (handler-bind ((error #'(lambda (e) - (with-http-response (:content-type "text/html; charset=UTF-8" - :response +http-internal-server-error+) - (with-http-body () - (website-show-error-page *website* e))) - (do-error-log-request e) - (error e)))) - (handle handler)))) + (handler-bind + ((error #'(lambda (e) + (with-http-response (:content-type "text/html; charset=UTF-8" + :response +http-internal-server-error+) + (return-from invoke-handler (prog1 + (with-http-body () + (website-show-error-page *website* e)) + (do-error-log-request e))))))) + (handle handler)) + (handle handler))) (handler-case (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files))) (error (e) @@ -468,8 +469,7 @@ (defgeneric xml-object-handler-show-object (handler object)) (defmethod xml-object-handler-show-object ((handler xml-object-handler) object) - (write-to-xml object - :string-rod-fn #'cxml::utf8-string-to-rod)) + (write-to-xml object)) (defmethod handle-object ((handler xml-object-handler) object) (xml-object-handler-show-object handler object)) @@ -499,8 +499,8 @@ (defmethod handle-object ((handler blob-handler) (blob blob)) (with-http-response (:content-type (blob-mime-type blob)) (setf (content-length) (blob-size blob)) - (with-http-body (:external-format '(unsigned-byte 8)) - (blob-to-stream blob *html-stream*)))) + (let ((stream (send-headers))) + (blob-to-stream blob stream)))) (defclass import-handler (form-handler) ((require-user-flag :initform :admin) @@ -522,7 +522,6 @@ (defmethod website-show-page ((website website) fn title) (html - (:html (:head (header :title title)) @@ -535,6 +534,20 @@ (funcall fn) (session-info))))) +(defmethod website-show-error-page ((website website) error) + (if (and (website-template-handler website) + (error-template-pathname (website-template-handler website))) + (send-error-response (website-template-handler website) (princ-to-string error)) + (html + (:html + (:head + (header :title "Error processing your request")) + ((:body :class "cms") + (:h1 "Error processing your request") + (:p "While processing your request, an error occured:") + ((:div :class "error") + (:princ-safe error))))))) + (defun show-page-with-error-handlers (fn &key (response +http-ok+) title) (setf (return-code) response) (with-http-response (:content-type "text/html; charset=UTF-8" :response response) Modified: branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp Fri Feb 15 16:22:21 2008 @@ -10,5 +10,5 @@ (defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel)) (with-http-response (:content-type "text/xml; charset=UTF-8") - (with-http-body () - (bknr.rss:rss-channel-xml channel *html-stream*)))) + (with-output-to-string (stream) + (bknr.rss:rss-channel-xml channel stream)))) Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Fri Feb 15 16:22:21 2008 @@ -262,13 +262,16 @@ env))) (template-not-found template-pathname)))) +(defmethod error-template-pathname (handler &optional (error-type "user-error")) + (find-template-pathname handler error-type)) + (defun send-error-response (handler message &key (response-code +http-internal-server-error+)) (with-http-response (:content-type "text/html; charset=UTF-8" :response response-code) (with-output-to-string (stream) (emit-template handler stream - (get-cached-template (find-template-pathname handler "user-error") handler) + (get-cached-template (error-template-pathname handler) handler) (acons :error-message message (initial-template-environment handler)))))) Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Fri Feb 15 16:22:21 2008 @@ -120,8 +120,7 @@ value)) (defun query-param-list (param-name) - (format *debug-io* "questionable: query-param-list~%") - (assoc-values param-name (request-query) :test #'string-equal)) + (assoc-values param-name (get-parameters) :test #'string-equal)) (defun request-variable (var) (gethash var *req-var-hash*)) Modified: branches/trunk-reorg/projects/quickhoney/website/static/styles.css ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/static/styles.css (original) +++ branches/trunk-reorg/projects/quickhoney/website/static/styles.css Fri Feb 15 16:22:21 2008 @@ -425,3 +425,11 @@ width: 0px; border: 0px none #FFFFFF; } + +.error { + margin: 2em; + padding: 1em; + border: 1pt solid #aa0000; + color:#f00; + font-size: 110%; +} \ No newline at end of file Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Fri Feb 15 16:22:21 2008 @@ -142,11 +142,8 @@ (defun emit-without-quoting (str) ;; das ist fuer WPDISPLAY - (format t "emit-without-quoting does not work~%") - #+(or) - (let ((s (cxml::chained-handler *html-sink*))) - (cxml::maybe-close-tag s) - (map nil (lambda (c) (cxml::write-rune c s)) str))) + (cxml::maybe-close-tag *html-sink*) + (map nil (lambda (c) (cxml::%write-rune c *html-sink*)) str)) (defun princ-http (val) #+(or)

1 0

[bknr-cvs] r2509 - branches/trunk-reorg/bknr/datastore/src/skip-list
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 11:43:14 2008 New Revision: 2509 Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp Log: Remove stale comment Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp Fri Feb 15 11:43:14 2008 @@ -4,8 +4,6 @@ ;;; index-protokoll fuer cursor ;;; range-queries -;;; Pseudo-random number generator from FreeBSD - (defparameter *sl-random-state* (make-random-state t) "Internal status of the random number generator.")

1 0

[bknr-cvs] r2508 - in branches/trunk-reorg/bknr: datastore/src/data datastore/src/indices datastore/src/skip-list modules/imagemap modules/mail web/src web/src/images web/src/web
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 11:40:28 2008 New Revision: 2508 Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mail.lisp branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp branches/trunk-reorg/bknr/web/src/images/image.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Log: Several changes to remove references to *html-stream*, not complete. Minor edits and reformats. Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/object.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp Fri Feb 15 11:40:28 2008 @@ -561,7 +561,7 @@ collect keyword and collect value)) - + ;;; create object transaction, should not be called from user code, as we have to give it ;;; a unique id in the initargs. After the object is created, the persistent and the ;;; transient instances are initialized Modified: branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp Fri Feb 15 11:40:28 2008 @@ -281,8 +281,7 @@ (defvar *indexed-class-override* nil) -(defmethod slot-value-using-class :before - ((class indexed-class) object slot) +(defmethod slot-value-using-class :before ((class indexed-class) object slot) (when (and (not (eql (slot-definition-name slot) 'destroyed-p)) (object-destroyed-p object) (not *indexed-class-override*)) Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp Fri Feb 15 11:40:28 2008 @@ -7,7 +7,7 @@ ;;; Pseudo-random number generator from FreeBSD (defparameter *sl-random-state* - (make-random-state) + (make-random-state t) "Internal status of the random number generator.") (defun sl-random () Modified: branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp Fri Feb 15 11:40:28 2008 @@ -77,11 +77,10 @@ (t (html (:p #?"unknown operation $(operation-string)")))) (html ((:form :action (self-url :command "make-polygon")) (if (session-value :map-points) - (progn - (format *html-stream* "~a point~:P collected " - (/ (length (session-value :map-points)) 2)) - (html (cmslink (self-url :command "clear-points") - (:princ "clear"))) + (html + (:princ (format nil "~A point~:P collected " + (/ (length (session-value :map-points)) 2))) + (cmslink (self-url :command "clear-points") (:princ "clear")) (when (< 4 (length (session-value :map-points))) (html " link to url: " ((:input :type "text" :name "url" :width 40)) " " ((:input :type "submit" :value "make polygon"))))) Modified: branches/trunk-reorg/bknr/modules/mail/mail.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mail.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mail.lisp Fri Feb 15 11:40:28 2008 @@ -43,15 +43,15 @@ (defmacro with-html-output-to-mail ((&rest mail-initargs &key headers &allow-other-keys) &rest body) (let ((new-headers (gensym))) - `(let ((,new-headers (make-headers :content-type "text/html; charset=\"utf-8\"" - :mime-version "1.0"))) - (when ,headers - (setf ,new-headers (append ,new-headers ,headers))) - (make-object 'mail - :headers ,new-headers - ,@(remove-keys '(:headers) mail-initargs) - :body (with-output-to-string (*html-stream*) - (html ,@body)))))) + `(let ((,new-headers (make-headers :content-type "text/html; charset=\"utf-8\"" + :mime-version "1.0"))) + (when ,headers + (setf ,new-headers (append ,new-headers ,headers))) + (make-object 'mail + :headers ,new-headers + ,@(remove-keys '(:headers) mail-initargs) + :body (with-output-to-string (s) + (html-stream s ,@body)))))) ;;; converted from macho (by Miles Egan) (defun parse-header-string (headerstr) Modified: branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp Fri Feb 15 11:40:28 2008 @@ -126,10 +126,10 @@ (with-bknr-page (:title #?"edit image $(name)") (when remove-keywords (store-object-remove-keywords image 'keywords remove-keywords) - (html (:h2 (format *html-stream* "Removed keywords ~a from image" remove-keywords)))) + (html (:h2 (:princ (format nil "Removed keywords ~a from image" remove-keywords))))) (when add-keywords (store-object-add-keywords image 'keywords add-keywords) - (html (:h2 (format *html-stream* "Added keywords ~a to image" add-keywords)))) + (html (:h2 (:princ (format nil "Added keywords ~a to image" add-keywords))))) (unless (or add-keywords remove-keywords) (html (:h2 "No keywords added or removed"))) (show-image-editor image)))) \ No newline at end of file Modified: branches/trunk-reorg/bknr/web/src/images/image.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image.lisp Fri Feb 15 11:40:28 2008 @@ -115,13 +115,12 @@ :title (store-image-name image) :link browse-url :desc (with-output-to-string (s) - (html-stream - s ((:a :href image-url) - ((:img :src - (concatenate 'string - image-url - "/thumbnail,,320,200") - :align "left"))))) + (html-stream s ((:a :href image-url) + ((:img :src + (concatenate 'string + image-url + "/thumbnail,,320,200") + :align "left"))))) :date (blob-timestamp image)))) ;;; import Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Fri Feb 15 11:40:28 2008 @@ -192,8 +192,7 @@ (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :hunchentoot #:host) (:shadowing-import-from :alexandria #:array-index) - (:export #:*html-stream* - #:*user* + (:export #:*user* #:with-http-request #:with-http-body #:request-variable Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Fri Feb 15 11:40:28 2008 @@ -265,9 +265,9 @@ (defun send-error-response (handler message &key (response-code +http-internal-server-error+)) (with-http-response (:content-type "text/html; charset=UTF-8" :response response-code) - (with-http-body () + (with-output-to-string (stream) (emit-template handler - *html-stream* + stream (get-cached-template (find-template-pathname handler "user-error") handler) (acons :error-message message (initial-template-environment @@ -316,8 +316,7 @@ (if body (with-http-response (:content-type "text/html; charset=UTF-8" :response +http-ok+) - (with-http-body () - (write-string body *html-stream*))) + body) (error-404))))) ;; XXX documentation-handler sieht interessant aus, unbedingt reparieren Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Fri Feb 15 11:40:28 2008 @@ -50,11 +50,9 @@ (setf (return-code) ,response) ,@body)) -(defvar *html-stream*) - (defmacro with-http-body ((&key external-format) &body body) - `(with-output-to-string (*html-stream*) - (with-xhtml (*html-stream*) + `(with-output-to-string (stream) + (with-xhtml (stream) ,@body))) (defmacro with-image-from-uri ((image-variable prefix) &rest body) @@ -83,7 +81,7 @@ (defmacro html-warn (&rest warning) `(progn - (format *html-stream* "~%" (format nil ,@warning)) + (html (:princ-safe (format nil "~%" (format nil ,@warning)))) (warn ,@warning))) (defmacro cmslink (url &body body) Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Fri Feb 15 11:40:28 2008 @@ -137,7 +137,6 @@ (defun http-error (response message) (with-bknr-page (:title #?"error: $(message)" :response response) (:princ-safe message)) - (finish-output *html-stream*) (error message)) (defun keywords-from-query-param-list (param &key (remove-empty t)) @@ -190,7 +189,7 @@ #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))")) (defmethod html-link ((object store-object)) - (format *html-stream* "[persistent object with id #~a]" (store-object-id object))) + (html (:princ (format nil "[persistent object with id #~a]" (store-object-id object))))) (defun text-to-html (string) "Perform simple text to HTML conversion. http urls are replaced by links, internal links to

1 0

[bknr-cvs] r2507 - branches/trunk-reorg/bknr/web/src/web
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 11:39:19 2008 New Revision: 2507 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp Log: Fixes for CXML compatibility. Create new random state for each request invocation (which is not good, but better than having all requests start with the same seed). Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Fri Feb 15 11:39:19 2008 @@ -223,7 +223,8 @@ (defmethod invoke-handler ((handler page-handler)) (let* ((*website* (page-handler-site handler)) (*req-var-hash* (or *req-var-hash* - (make-hash-table)))) + (make-hash-table))) + (*random-state* (make-random-state t))) (do-log-request) (unwind-protect (if (not (authorized-p handler)) @@ -446,8 +447,8 @@ (defmethod handle :around ((handler xml-handler)) (with-http-response (:content-type "text/xml") - (with-http-body () - (let ((sink (cxml:make-character-stream-sink *html-stream* :canonical t)) + (with-output-to-string (stream) + (let ((sink (cxml:make-character-stream-sink stream :canonical t)) (style-path (or (query-param "style") (xml-handler-style-path handler)))) (cxml:with-xml-output sink

1 0

[bknr-cvs] r2506 - branches/trunk-reorg/thirdparty/usocket-0.3.5/backend
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 11:37:07 2008 New Revision: 2506 Modified: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp Log: Fix openmcl implementation of select (partly) Modified: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp (original) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp Fri Feb 15 11:37:07 2008 @@ -37,15 +37,15 @@ (ccl::fd-zero infds) (ccl::fd-zero errfds) (dolist (sock sockets) - (ccl::fd-set (socket-os-fd sock infds)) - (ccl::fd-set (socket-os-fd sock errfds))) + (ccl::fd-set (ccl::socket-os-fd sock) infds) + (ccl::fd-set (ccl::socket-os-fd sock) errfds)) (let* ((res (ccl::syscall syscalls::select - (1+ (apply #'max fds)) + (1+ (apply #'max (mapcar #'ccl::socket-os-fd sockets))) infds (ccl::%null-ptr) errfds (if ticks-to-wait tv (ccl::%null-ptr))))) (when (> res 0) (remove-if #'(lambda (x) - (not (ccl::fd-is-set (socket-os-fd x) infds))) + (not (ccl::fd-is-set (ccl::socket-os-fd x) infds))) sockets)))))) (defun wait-for-input (sockets &optional ticks-to-wait) @@ -67,7 +67,7 @@ (raise-error-from-id (openmcl-socket:socket-error-identifier condition) socket condition)) (ccl::socket-creation-error #| ugh! |# - (raise-error-from-id (ccl::socket-creationg-error-identifier condition) + (raise-error-from-id (ccl::socket-creation-error-identifier condition) socket condition)) (error (error 'unknown-error :socket socket :real-error condition)) (condition (signal 'unknown-condition :real-condition condition))))

1 0

[bknr-cvs] r2505 - branches/trunk-reorg/thirdparty/chunga-0.4.1
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 11:36:25 2008 New Revision: 2505 Modified: branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp Log: Fix CCL warnings Modified: branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp (original) +++ branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp Fri Feb 15 11:36:25 2008 @@ -31,15 +31,18 @@ (defmethod chunked-input-stream-extensions (object) "The default method which always returns the empty list." + (declare (ignore object)) nil) (defmethod chunked-input-stream-trailers (object) "The default method which always returns the empty list." + (declare (ignore object)) nil) (defmethod chunked-stream-input-chunking-p (object) "The default method for all objects which are not of type CHUNKED-INPUT-STREAM." + (declare (ignore object)) nil) (defmethod (setf chunked-stream-input-chunking-p) (new-value (stream chunked-input-stream)) Modified: branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp (original) +++ branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp Fri Feb 15 11:36:25 2008 @@ -32,6 +32,7 @@ (defmethod chunked-stream-output-chunking-p (object) "The default method for all objects which are not of type CHUNKED-OUTPUT-STREAM." + (declare (ignore object)) nil) (defmethod write-chunk ((stream chunked-output-stream) sequence

1 0

[bknr-cvs] r2504 - in branches/trunk-reorg/projects/quickhoney: src website/static website/templates
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 11:33:56 2008 New Revision: 2504 Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/tags.lisp branches/trunk-reorg/projects/quickhoney/website/static/javascript.js branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Log: Fix Javascript handling so that it works with current CXML. Fix direct navigation to category page. Reformats. Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/handlers.lisp Fri Feb 15 11:33:56 2008 @@ -5,13 +5,17 @@ (defclass javascript-handler () ()) +(defvar *js-stream*) + (defmethod handle :around ((handler javascript-handler)) (with-http-response (:content-type "text/html; charset=UTF-8") (no-cache) (with-http-body () - (format *html-stream* "<script language=\"JavaScript\">~%") - (call-next-method) - (format *html-stream* "~%</script>~%")))) + (html + ((:script :language "JavaScript") + (:princ + (with-output-to-string (*js-stream*) + (call-next-method)))))))) (defclass random-image-handler (object-handler) ()) @@ -29,7 +33,7 @@ (let ((content-type (blob-type (quickhoney-animation-image-animation animation)))) (with-http-response (:content-type content-type) (with-http-body () - (blob-to-stream (quickhoney-animation-image-animation animation) *html-stream*))))) + (blob-to-stream (quickhoney-animation-image-animation animation) *js-stream*))))) (defclass image-query-js-handler (javascript-handler object-handler) ()) @@ -62,19 +66,19 @@ (format t "]~%"))) (defmethod handle-object ((handler image-query-js-handler) images) - (format *html-stream* "parent.process_query_result(~%") + (format *js-stream* "parent.process_query_result(~%") (with-query-params (layout) (princ (layout-to-javascript (make-instance (case (make-keyword-from-string layout) (:smallworld 'quickhoney-name-layout) (t 'quickhoney-standard-layout)) - :objects images)) *html-stream*)) - (format *html-stream* ");~%")) + :objects images)) *js-stream*)) + (format *js-stream* ");~%")) (defclass login-js-handler (javascript-handler page-handler) ()) (defmethod handle ((handler login-js-handler)) - (format *html-stream* "parent.login_complete(~A, ~S);~%" + (format *js-stream* "parent.login_complete(~A, ~S);~%" (if (admin-p (bknr-session-user)) "true" "false") (user-login (bknr-session-user)))) @@ -84,7 +88,7 @@ (defmethod handle ((handler clients-js-handler)) (let ((clients (sort (remove "" (all-clients) :test #'equal) #'string-lessp))) - (format *html-stream* "parent.set_clients([~S~{, ~S~}]);~%" + (format *js-stream* "parent.set_clients([~S~{, ~S~}]);~%" (car clients) (cdr clients)))) (defclass edit-image-js-handler (admin-only-handler javascript-handler edit-object-handler) @@ -97,11 +101,11 @@ (defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :edit)) image) (with-query-params (client) (change-slot-values image 'client client) - (format *html-stream* "parent.image_edited()~%"))) + (format *js-stream* "parent.image_edited()~%"))) (defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :delete)) (image quickhoney-image)) (delete-object image) - (format *html-stream* "parent.image_deleted();~%")) + (format *js-stream* "parent.image_deleted();~%")) (defclass buttons-js-handler (javascript-handler prefix-handler) ()) @@ -138,11 +142,11 @@ collect (list category subcategory (button-for-category category subcategory background-color)))))) (defmethod handle ((handler buttons-js-handler)) - (format *html-stream* "var buttons = [];~%") + (format *js-stream* "var buttons = [];~%") (loop for (category subcategory image-url) in (find-button-images (decoded-handler-path handler)) when image-url - do (format *html-stream* "buttons['~(~A/~A~)'] = ~S;~%" category subcategory image-url)) - (format *html-stream* "parent.set_button_images(buttons);~%")) + do (format *js-stream* "buttons['~(~A/~A~)'] = ~S;~%" category subcategory image-url)) + (format *js-stream* "parent.set_button_images(buttons);~%")) (defclass upload-image-handler (admin-only-handler prefix-handler) ()) @@ -259,7 +263,9 @@ (error "invalid image size, buttons must be 208 by 208 pixels")) (let* ((image (make-store-image :name (pathname-name uploaded-file) :class-name 'store-image - :keywords (list :button (make-keyword-from-string directory) (make-keyword-from-string subdirectory))))) + :keywords (list :button + (make-keyword-from-string directory) + (make-keyword-from-string subdirectory))))) (with-http-response () (with-http-body () (html (:html Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/tags.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp Fri Feb 15 11:33:56 2008 @@ -1,7 +1,6 @@ (in-package :quickhoney.tags) (define-bknr-tag version-and-last-change (&rest args) - (format *debug-io* "hello world: ~A~%" args) (html "v1.1 | updated " (:princ-safe (string-downcase (substitute #\Space #\- Modified: branches/trunk-reorg/projects/quickhoney/website/static/javascript.js ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/static/javascript.js (original) +++ branches/trunk-reorg/projects/quickhoney/website/static/javascript.js Fri Feb 15 11:33:56 2008 @@ -607,8 +607,10 @@ var components = document.jump_to.split("/"); document.jump_to = null; show_page(components[0]); - subdirectory(components[1]); - document.show_picture = components[2]; + if (components[1]) { + subdirectory(components[1]); + } + document.show_picture = components[2]; } } Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml (original) +++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Fri Feb 15 11:33:56 2008 @@ -127,7 +127,7 @@ </div> <div id="footer" class="text"> - ©1998-2006 QuickHoney Nana Rausch & Peter Stemmler. No part of + ©1998-2008 QuickHoney Nana Rausch & Peter Stemmler. No part of this website may be reproduced in any manner without permission. Programming by Hübner/Odendahl <a href="http://headcraft.de/" target="_new"> headcraft</a>

1 0

[bknr-cvs] r2503 - branches/trunk-reorg/bknr/datastore/src/data
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 08:41:20 2008 New Revision: 2503 Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp Log: Rename and document some things. Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/object.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp Fri Feb 15 08:41:20 2008 @@ -5,8 +5,9 @@ (cl-interpol:enable-interpol-syntax) (defclass store-object-subsystem () - ((id-counter :initform 0 - :accessor id-counter))) + ((next-object-id :initform 0 + :accessor next-object-id + :documentation "Next object ID to assign to a new object"))) (defun store-object-subsystem () (let ((subsystem (find-if (lambda (subsystem) @@ -163,17 +164,16 @@ (anonymous-transaction-transactions *current-transaction*))) (call-next-method))) -(defmethod initialize-instance :after - ((object store-object) &key id &allow-other-keys) +(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) (let ((subsystem (store-object-subsystem))) (cond (id ;; during restore, use the given ID - (when (>= id (id-counter subsystem)) - (setf (id-counter subsystem) (1+ id)))) + (when (>= id (next-object-id subsystem)) + (setf (next-object-id subsystem) (1+ id)))) (t ;; normal transaction: assign a new ID - (setf id (id-counter subsystem)) - (incf (id-counter subsystem)) + (setf id (next-object-id subsystem)) + (incf (next-object-id subsystem)) (setf (slot-value object 'id) id))))) (defmethod print-object ((object store-object) stream) @@ -476,9 +476,9 @@ id slot-name (type-of container) (store-object-id container)) (warn "Reference to inexistent object with id ~A from unnamed container, returning NIL." id)) - ;; noch die ID hochzaehlen wenn notwendig - (when (>= id (id-counter (store-object-subsystem))) - (setf (id-counter (store-object-subsystem)) (1+ id))) + ;; Possibly determine new "current object id" + (when (>= id (next-object-id (store-object-subsystem))) + (setf (next-object-id (store-object-subsystem)) (1+ id))) nil) (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A." id slot-name (type-of container) @@ -512,7 +512,7 @@ ;;; check on first instatiation of a class? (dolist (class-name (cons 'store-object (all-store-classes))) (clear-class-indices (find-class class-name))) - (setf (id-counter subsystem) 0) + (setf (next-object-id subsystem) 0) (when (probe-file snapshot) (format *trace-output* "loading snapshot file ~A~%" snapshot) (with-open-file (s snapshot @@ -586,7 +586,7 @@ (execute (make-instance 'transaction :function-symbol 'tx-make-object :args (append (list class-name - :id (id-counter (store-object-subsystem))) + :id (next-object-id (store-object-subsystem))) initargs)))) (defun tx-delete-object (id)

1 0