mailman3.common-lisp.net
Sign In
Sign Up
Sign In
Sign Up
Manage this list
×
Keyboard Shortcuts
Thread View
j
: Next unread message
k
: Previous unread message
j a
: Jump to all threads
j l
: Jump to MailingList overview
2025
January
2024
December
November
October
September
August
July
June
May
April
March
February
January
2023
December
November
October
September
August
July
June
May
April
March
February
January
2022
December
November
October
September
August
July
June
May
April
March
February
January
2021
December
November
October
September
August
July
June
May
April
March
February
January
2020
December
November
October
September
August
July
June
May
April
March
February
January
2019
December
November
October
September
August
July
June
May
April
March
February
January
2018
December
November
October
September
August
July
June
May
April
March
February
January
2017
December
November
October
September
August
July
June
May
April
March
February
January
2016
December
November
October
September
August
July
June
May
April
March
February
January
2015
December
November
October
September
August
July
June
May
April
March
February
January
2014
December
November
October
September
August
July
June
May
April
March
February
January
2013
December
November
October
September
August
July
June
May
April
March
February
January
2012
December
November
October
September
August
July
June
May
April
March
February
January
2011
December
November
October
September
August
July
June
May
April
March
February
January
2010
December
November
October
September
August
July
June
May
April
March
February
January
2009
December
November
October
September
August
July
June
May
April
March
February
January
2008
December
November
October
September
August
July
June
May
April
March
February
January
2007
December
November
October
September
August
July
June
May
April
March
February
January
2006
December
November
October
September
August
July
June
May
April
March
February
January
List overview
Download
bknr-cvs
February 2008
----- 2025 -----
January 2025
----- 2024 -----
December 2024
November 2024
October 2024
September 2024
August 2024
July 2024
June 2024
May 2024
April 2024
March 2024
February 2024
January 2024
----- 2023 -----
December 2023
November 2023
October 2023
September 2023
August 2023
July 2023
June 2023
May 2023
April 2023
March 2023
February 2023
January 2023
----- 2022 -----
December 2022
November 2022
October 2022
September 2022
August 2022
July 2022
June 2022
May 2022
April 2022
March 2022
February 2022
January 2022
----- 2021 -----
December 2021
November 2021
October 2021
September 2021
August 2021
July 2021
June 2021
May 2021
April 2021
March 2021
February 2021
January 2021
----- 2020 -----
December 2020
November 2020
October 2020
September 2020
August 2020
July 2020
June 2020
May 2020
April 2020
March 2020
February 2020
January 2020
----- 2019 -----
December 2019
November 2019
October 2019
September 2019
August 2019
July 2019
June 2019
May 2019
April 2019
March 2019
February 2019
January 2019
----- 2018 -----
December 2018
November 2018
October 2018
September 2018
August 2018
July 2018
June 2018
May 2018
April 2018
March 2018
February 2018
January 2018
----- 2017 -----
December 2017
November 2017
October 2017
September 2017
August 2017
July 2017
June 2017
May 2017
April 2017
March 2017
February 2017
January 2017
----- 2016 -----
December 2016
November 2016
October 2016
September 2016
August 2016
July 2016
June 2016
May 2016
April 2016
March 2016
February 2016
January 2016
----- 2015 -----
December 2015
November 2015
October 2015
September 2015
August 2015
July 2015
June 2015
May 2015
April 2015
March 2015
February 2015
January 2015
----- 2014 -----
December 2014
November 2014
October 2014
September 2014
August 2014
July 2014
June 2014
May 2014
April 2014
March 2014
February 2014
January 2014
----- 2013 -----
December 2013
November 2013
October 2013
September 2013
August 2013
July 2013
June 2013
May 2013
April 2013
March 2013
February 2013
January 2013
----- 2012 -----
December 2012
November 2012
October 2012
September 2012
August 2012
July 2012
June 2012
May 2012
April 2012
March 2012
February 2012
January 2012
----- 2011 -----
December 2011
November 2011
October 2011
September 2011
August 2011
July 2011
June 2011
May 2011
April 2011
March 2011
February 2011
January 2011
----- 2010 -----
December 2010
November 2010
October 2010
September 2010
August 2010
July 2010
June 2010
May 2010
April 2010
March 2010
February 2010
January 2010
----- 2009 -----
December 2009
November 2009
October 2009
September 2009
August 2009
July 2009
June 2009
May 2009
April 2009
March 2009
February 2009
January 2009
----- 2008 -----
December 2008
November 2008
October 2008
September 2008
August 2008
July 2008
June 2008
May 2008
April 2008
March 2008
February 2008
January 2008
----- 2007 -----
December 2007
November 2007
October 2007
September 2007
August 2007
July 2007
June 2007
May 2007
April 2007
March 2007
February 2007
January 2007
----- 2006 -----
December 2006
November 2006
October 2006
September 2006
August 2006
July 2006
June 2006
May 2006
April 2006
March 2006
February 2006
January 2006
bknr-cvs@common-lisp.net
3 participants
128 discussions
Start a n
N
ew thread
[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/
…
[View More]
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))
[View Less]
1
0
0
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) + (
…
[View More]
cd ../.. && find . -name '*.x86f' | xargs rm -f) .PHONY: cleanall cleanall: cleancore cleanfasl
[View Less]
1
0
0
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
…
[View More]
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)
[View Less]
1
0
0
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
…
[View More]
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.")
[View Less]
1
0
0
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/
…
[View More]
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* "<!-- ~a -->~%" (format nil ,@warning)) + (html (:princ-safe (format nil "<!-- ~a -->~%" (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
[View Less]
1
0
0
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.
…
[View More]
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
[View Less]
1
0
0
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/
…
[View More]
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))))
[View Less]
1
0
0
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
…
[View More]
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
[View Less]
1
0
0
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/
…
[View More]
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>
[View Less]
1
0
0
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 @@ (
…
[View More]
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)
[View Less]
1
0
0
0
← Newer
1
2
3
4
5
6
7
8
9
...
13
Older →
Jump to page:
1
2
3
4
5
6
7
8
9
10
11
12
13
Results per page:
10
25
50
100
200