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

[bknr-cvs] r2434 - in branches/trunk-reorg/bknr/web/src: . rss web
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 07:53:36 2008 New Revision: 2434 Modified: branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/rss/rss.lisp 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/templates.lisp Log: Fix some RSS related problems. Extend RSS API so that encoded content can be generated. Begin removing all code that depends on :rune-is-integer. Raymond Toy says that he'll add Unicode support to CMUCL, and I'm sick of the string-related kludging. 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 Thu Jan 31 07:53:36 2008 @@ -65,6 +65,7 @@ #:rss-item-enclosure #:rss-item-guid #:rss-item-source + #:rss-item-encoded-content ;; textinput #:rss-textinput Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/rss.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp Thu Jan 31 07:53:36 2008 @@ -74,6 +74,7 @@ (with-xml-output (make-character-stream-sink stream) (with-element "rss" (attribute "version" "2.0") + (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/") (with-element "channel" (dolist (slot '(title link description)) (render-mandatory-element channel slot)) @@ -145,7 +146,10 @@ (with-element "description" (cdata it))) (with-element "pubDate" - (text (format-date-time (rss-item-pub-date item) :mail-style t))))) + (text (format-date-time (rss-item-pub-date item) :mail-style t))) + (aif (rss-item-encoded-content item) + (with-element* ("content" "encoded" ) + (cdata it))))) ;; All items present on an RSS stream can implement the access ;; methods below. @@ -169,4 +173,8 @@ (defmethod rss-item-enclosure (item)) (defmethod rss-item-guid (item)) (defmethod rss-item-source (item)) - +(defgeneric rss-item-encoded-content (item) + (:documentation "Return the content for ITEM in encoded (usually HTML) form as string.") + (:method (item) + (declare (ignore item)) + nil)) 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 Thu Jan 31 07:53:36 2008 @@ -427,9 +427,7 @@ (defmethod handle :around ((handler xml-handler)) (with-http-response (:content-type "text/xml") (with-http-body () - (let ((sink (#-rune-is-integer cxml:make-character-stream-sink - #+rune-is-integer cxml:make-character-stream-sink/utf8 - *html-stream* :canonical t)) + (let ((sink (cxml:make-character-stream-sink *html-stream* :canonical t)) (style-path (or (query-param "style") (xml-handler-style-path handler)))) (cxml:with-xml-output sink 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 Thu Jan 31 07:53:36 2008 @@ -11,5 +11,4 @@ (defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel)) (with-http-response (:content-type "text/xml; charset=UTF-8") (with-http-body () - (html (:princ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>") - (bknr.rss:rss-channel-xml channel *html-stream*))))) + (bknr.rss:rss-channel-xml channel *html-stream*)))) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Thu Jan 31 07:53:36 2008 @@ -103,8 +103,7 @@ (defun emit-template (expander stream node env) (let* ((*template-expander* expander) (*template-env* env) - (sink (#-rune-is-integer cxml:make-character-stream-sink #+rune-is-integer cxml:make-character-stream-sink/utf8 - stream :canonical nil)) + (sink (cxml:make-character-stream-sink stream :canonical nil)) (*html-sink* (cxml:make-recoder sink #'cxml::utf8-string-to-rod))) (if (node-attribute node "suppress-xml-headers") (emit-template-node node)

1 0

[bknr-cvs] r2433 - branches/trunk-reorg/xhtmlgen
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 07:33:43 2008 New Revision: 2433 Modified: branches/trunk-reorg/xhtmlgen/package.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: Change xhtmlgen again so that it does not depend on Alexandria just for the sake of WITH-GENSYMS. Modified: branches/trunk-reorg/xhtmlgen/package.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp (original) +++ branches/trunk-reorg/xhtmlgen/package.lisp Thu Jan 31 07:33:43 2008 @@ -1,7 +1,7 @@ (in-package :cl-user) (defpackage :xhtml-generator - (:use :common-lisp :alexandria) + (:use :common-lisp) (:export #:html #:html-stream #:*html-sink* Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Thu Jan 31 07:33:43 2008 @@ -46,7 +46,7 @@ (defmacro html (&rest forms &environment env) ;; just emit html to the current stream - (with-gensyms (body) + (let ((body (gensym))) `(labels ((,body () ,(process-html-forms forms env))) (if (boundp '*html-sink*)

1 0

[bknr-cvs] r2432 - branches/trunk-reorg/xhtmlgen
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 07:32:06 2008 New Revision: 2432 Modified: branches/trunk-reorg/xhtmlgen/package.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: Fix xhtmlgen so that it properly flushes the output ystream when it is done. Modified: branches/trunk-reorg/xhtmlgen/package.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp (original) +++ branches/trunk-reorg/xhtmlgen/package.lisp Thu Jan 31 07:32:06 2008 @@ -1,7 +1,7 @@ (in-package :cl-user) (defpackage :xhtml-generator - (:use :common-lisp) + (:use :common-lisp :alexandria) (:export #:html #:html-stream #:*html-sink* Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Thu Jan 31 07:32:06 2008 @@ -24,7 +24,6 @@ (in-package :xhtml-generator) -;; fixme (defvar *html-sink*) ;; html generation @@ -45,48 +44,21 @@ (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes ) -;; support for strings encoded in latin-1 or utf-8 on non-unicode lisps - -#-rune-is-character -(defun make-sink-for-utf8-strings (stream) - (cxml:make-recoder (cxml:make-character-stream-sink/utf8 stream :canonical nil :indentation 3) - #'cxml::utf8-string-to-rod)) - -#-rune-is-character -(defun make-sink-for-latin1-strings (stream) - (cxml:make-recoder (cxml:make-character-stream-sink/utf8 stream :canonical nil :indentation 3) - #'cxml::string-rod)) - -#-rune-is-character -(defvar *make-sink-for-internal-strings-fn* #'make-sink-for-utf8-strings) - -#-rune-is-character -(defun make-sink-for-internal-strings (stream) - (funcall *make-sink-for-internal-strings-fn* stream)) - -#-rune-is-character -(defun set-string-encoding (encoding) - (ecase encoding - (:latin-1 (setf *make-sink-for-internal-strings-fn* #'make-sink-for-latin1-strings)) - (:utf-8 (setf *make-sink-for-internal-strings-fn* #'make-sink-for-utf8-strings)))) - (defmacro html (&rest forms &environment env) ;; just emit html to the current stream - `(let ((*html-sink* (if (boundp '*html-sink*) - *html-sink* - #+rune-is-character - (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3) - #-rune-is-character - (make-sink-for-internal-strings *standard-output*)))) - ,(process-html-forms forms env))) + (with-gensyms (body) + `(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*)))))) (defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* - #+rune-is-character - (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3) - #-rune-is-character - (make-sink-for-internal-strings ,stream))) - ,(process-html-forms forms env))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3))) + ,(process-html-forms forms env) + (sax:end-document *html-sink*))) (defun get-process (form) (let ((ent (gethash form *html-process-table*)))

1 0

[bknr-cvs] r2431 - branches/trunk-reorg/projects/quickhoney/src
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:51:58 2008 New Revision: 2431 Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp Log: Produce warning message for invalid query. Change path in library loading hack. 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 Thu Jan 31 05:51:58 2008 @@ -122,7 +122,12 @@ (let ((preproduced-buttons (buttons-for-category category subcategory))) (if preproduced-buttons (format nil "/image/~D" (store-object-id (random-elt preproduced-buttons))) - (format nil "/image/~D/cutout-button,~(~A~),~A" (store-object-id (random-elt (subseq (images-sorted-by-time category subcategory) 0 10))) subcategory background-color)))) + (let ((images (images-sorted-by-time category subcategory))) + (if images + (format nil "/image/~D/cutout-button,~(~A~),~A" + (store-object-id (random-elt (subseq images 0 10))) + subcategory background-color) + (warn "No images for ~A ~A found"category subcategory)))))) (defun find-button-images (query-elements) (loop for (category-string subcategories-string) on query-elements by #'cddr Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Thu Jan 31 05:51:58 2008 @@ -4,7 +4,10 @@ (setq cxml::*default-catalog* '("/home/hans/share/xml/catalog")) ;; XXX hack hack hack (mapcar #'cl-gd::load-foreign-library - '("/usr/lib/libcrypto.so" "/usr/lib/libssl.so" "/usr/local/lib/libgd.so" "/home/hans/bknr-svn/thirdparty/cl-gd/cl-gd-glue.so")) + '("/usr/lib/libcrypto.so" + "/usr/lib/libssl.so" + "/usr/local/lib/libgd.so" + "/home/hans/bknr-svn/thirdparty/cl-gd-0.5.6/cl-gd-glue.so")) (when *store* (close-store)) (make-instance 'store

1 0

[bknr-cvs] r2430 - in branches/trunk-reorg/bknr: datastore/src/utils modules/feed modules/mail modules/stats modules/text web/src web/src/images web/src/web
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:50:52 2008 New Revision: 2430 Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp branches/trunk-reorg/bknr/modules/text/article-tags.lisp branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image-tags.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/menu.lisp branches/trunk-reorg/bknr/web/src/web/sessions.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/bknr/web/src/web/templates.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Log: Replace (request-uri) by (script-name), as the former may contain query parameters. Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp Thu Jan 31 05:50:52 2008 @@ -54,8 +54,6 @@ #:group-on #:find-all #:genlist - #+no-alexandria - #:rotate #:nrotate #:shift-until #:count-multiple @@ -67,8 +65,6 @@ #:incf-hash ;; randomize - #+no-alexandria - #:random-elt #:random-elts #:randomize-list Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp Thu Jan 31 05:50:52 2008 @@ -351,11 +351,6 @@ (setf l (randomize l))))) l) -#+no-alexandria -(defun random-elt (choices) - (when choices - (elt choices (random (length choices))))) - (defun random-elts (choices num) (subseq (randomize-list choices) 0 num)) Modified: branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -45,7 +45,7 @@ object) (let* ((title (object-list-handler-title handler object)) (feeds (object-list-handler-get-objects handler object)) - (rss-feed (merge-feeds title (render-uri (request-uri) nil) + (rss-feed (merge-feeds title (render-uri (script-name) nil) title (remove nil (mapcar #'feed-rss-feed feeds)))) (grouped-items (rss-feed-group-items rss-feed))) grouped-items)) @@ -135,7 +135,7 @@ (defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword) (let ((feeds (object-list-handler-get-objects handler keyword))) (merge-feeds (object-list-handler-title handler keyword) - (render-uri (request-uri) nil) + (render-uri (script-name) nil) (object-list-handler-title handler keyword) (remove nil (mapcar #'feed-rss-feed feeds))))) Modified: branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -172,7 +172,7 @@ ((:table :border "1") (:tr (:td "Name") (:td (:princ-safe (mailinglist-name mailinglist)))) (:tr (:td "Email") (:td (:princ-safe (mailinglist-email mailinglist))))) - ((:form :action (request-uri) :method "post") + ((:form :action (script-name) :method "post") (:table (:tr (:td "Subscribe email") (:td (text-field "email")))) (submit-button "subscribe" "subscribe")))) Modified: branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp Thu Jan 31 05:50:52 2008 @@ -41,7 +41,7 @@ (html (:table (:tr (:td "Date") (:td (:princ-safe (format-date-time time)))) (:tr (:td "URL") (:td (cmslink - (render-uri (merge-uris url (request-uri)) nil) + (render-uri (merge-uris url (script-name)) nil) (:princ-safe url)))) (:tr ((:td :colspan "2") (:princ-safe error))) (:tr ((:td :colspan "2") (:pre (:princ-safe backtrace)))))))))) Modified: branches/trunk-reorg/bknr/modules/text/article-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-tags.lisp Thu Jan 31 05:50:52 2008 @@ -221,7 +221,7 @@ (if (= i page) (html (:princ-safe i)) (html ((:a :href (format nil "~A?page=~A" - (request-uri) i)) + (script-name) i)) (:princ-safe i)))) " ")) (loop for result in results Modified: branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -22,7 +22,7 @@ (let ((may-edit (admin-p (bknr-session-user)))) (with-bknr-page (:title "billboards") (html - ((:form :method "post" :action (request-uri)) + ((:form :method "post" :action (script-name)) ((:table :width "640") (:tr (:th "name") (:th "new" :br "msgs") Modified: branches/trunk-reorg/bknr/web/src/images/image-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-tags.lisp Thu Jan 31 05:50:52 2008 @@ -13,7 +13,7 @@ (html (:princ " ") (if (= i page) (html (:princ-safe i)) - (html (cmslink (format nil "~A?page=~A" (request-uri) i) (:princ-safe i)))) + (html (cmslink (format nil "~A?page=~A" (script-name) i) (:princ-safe i)))) (:princ " "))))))) (define-bknr-tag banner (&key link keyword width height) Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Thu Jan 31 05:50:52 2008 @@ -133,8 +133,6 @@ (with-default-image (input-image) (let ((colors (loop for (old new) on color-mappings by #'cddr collect (cons (parse-color old) (parse-color new))))) - #+nil - (format t "color: ~A~%" colors) (do-pixels (input-image) (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) (when (cdr new-color) 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 Thu Jan 31 05:50:52 2008 @@ -401,6 +401,7 @@ :cl-gd :cl-interpol :cl-ppcre + :alexandria :hunchentoot :puri :xhtml-generator @@ -411,6 +412,7 @@ :bknr.utils :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) + (:shadowing-import-from :bknr.indices #:array-index) (:export #:imageproc #:define-imageproc-handler #:image-handler ; plain images only 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 Thu Jan 31 05:50:52 2008 @@ -196,7 +196,7 @@ (defgeneric page-handler-url (page-handler)) (defmethod handler-path ((handler page-handler)) - (subseq (request-uri) + (subseq (script-name) (length (page-handler-prefix handler)))) (defmethod decoded-handler-path ((handler page-handler)) @@ -233,7 +233,7 @@ (if (not (authorized-p handler)) (progn (setf (session-value :login-redirect-uri) - (redirect-uri (request-uri))) + (redirect-uri (script-name))) (redirect (website-make-path *website* "login"))) (if *catch-errors-p* (handle handler) @@ -320,13 +320,18 @@ ((destination :initarg :destination :reader page-handler-destination))) +(defmethod request-pathname ((handler directory-handler)) + (or (aux-request-value 'request-pathname) + (setf (aux-request-value 'request-pathname) + (subseq (script-name) (1+ (length (page-handler-prefix handler))))))) + (defmethod handler-matches ((handler directory-handler)) (and (call-next-method) - (probe-file (merge-pathnames (script-name) + (probe-file (merge-pathnames (request-pathname handler) (page-handler-destination handler))))) (defmethod handle ((handler directory-handler)) - (handle-static-file (merge-pathnames (subseq (script-name) (1+ (length (page-handler-prefix handler)))) + (handle-static-file (merge-pathnames (request-pathname handler) (page-handler-destination handler)))) (defclass file-handler (page-handler) Modified: branches/trunk-reorg/bknr/web/src/web/menu.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/menu.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/menu.lisp Thu Jan 31 05:50:52 2008 @@ -50,7 +50,7 @@ (when title (html ((:div :class "title") (:princ-safe title)))) (dolist (item (menu-items menu)) - (let ((item-is-active (in-subtree (request-uri) (item-url item)))) + (let ((item-is-active (in-subtree (script-name) (item-url item)))) (with-slots (url title active-image inactive-image) item (let ((link-url (format nil "~A~A" (website-base-href *website*) url))) (cond Modified: branches/trunk-reorg/bknr/web/src/web/sessions.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/sessions.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/sessions.lisp Thu Jan 31 05:50:52 2008 @@ -18,13 +18,13 @@ (slot-value (bknr-session) 'user)) (defun do-log-request () - (format *debug-io* "Log: ~A~%" (request-uri)) + (format *debug-io* "Log: ~A~%" (script-name)) (return-from do-log-request) #+(or) (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) - (url (request-uri)) + (url (script-name)) (referer (header-in :referer)) (user-agent (header-in :user-agent)) (time (get-universal-time))) @@ -46,7 +46,7 @@ (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) - (url (request-uri)) + (url (script-name)) (referer (header-in :referer)) (time (get-universal-time))) (make-event 'web-server-error-event Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Thu Jan 31 05:50:52 2008 @@ -198,7 +198,7 @@ (define-bknr-tag navi-button (&key url text) (html (:princ " ")) - (if (equal (request-uri) + (if (equal (script-name) url) (html (:princ-safe text)) (html (cmslink url (:princ-safe text)))) @@ -255,7 +255,7 @@ (define-bknr-tag site-menu () (destructuring-bind (empty first-level &optional second-level &rest rest) - (split "/" (request-uri)) + (split "/" (script-name)) (declare (ignore empty rest)) (html ((:div :id "navcontainer") (let ((*standard-output* *html-stream*)) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Thu Jan 31 05:50:52 2008 @@ -294,7 +294,7 @@ (defmethod handler-matches ((handler template-handler)) (handler-case - (find-template-pathname handler (request-uri)) + (find-template-pathname handler (script-name)) (template-not-found (c) (declare (ignore c)) nil))) @@ -304,7 +304,7 @@ ;; Erst body ausfuehren... (let ((body (expand-template handler - (subseq (request-uri) + (subseq (script-name) (length (page-handler-prefix handler))) :env (initial-template-environment handler)))) ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben 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 Thu Jan 31 05:50:52 2008 @@ -59,7 +59,7 @@ (defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (request-uri)) + (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))))) 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 Thu Jan 31 05:50:52 2008 @@ -108,7 +108,7 @@ (mapcar (lambda (param) (cons (car param) (iconv:iconv request-charset "utf-8" (cdr param)))) - (remove "" (append (form-urlencoded-to-query (uri-query (request-uri))) + (remove "" (append (form-urlencoded-to-query (uri-query (script-name))) (aux-request-value 'bknr-parsed-body-parameters)) :key #'cdr :test #'string-equal))))) (aux-request-value 'bknr-parsed-parameters)) @@ -157,11 +157,11 @@ (#\> ">"))))) (defun parse-url () - (values-list (cddr (mapcar #'url-decode (split "/" (request-uri)))))) + (values-list (cddr (mapcar #'url-decode (split "/" (script-name)))))) (defun last-url-component () (register-groups-bind (last) - ("/([^\\/]+)$" (request-uri)) + ("/([^\\/]+)$" (script-name)) last)) (defun parse-date-field (name) @@ -180,12 +180,12 @@ (defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" (let ((len (length (page-handler-prefix handler)))) - (subseq (request-uri) len))) + (subseq (script-name) len))) (defun self-url (&key command prefix) (destructuring-bind (empty old-prefix object-id &rest old-command) - (split "/" (request-uri)) + (split "/" (script-name)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))"))

1 0

[bknr-cvs] r2429 - branches/trunk-reorg/thirdparty/cl-gd-0.5.6
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:46:46 2008 New Revision: 2429 Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp Log: Fix buglet with DO-PIXELS/GET-PIXEL that made SBCL choke. Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp (original) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp Thu Jan 31 05:46:46 2008 @@ -220,12 +220,12 @@ (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) (declare (type pixels-array ,raw-pixels)) (dotimes (,y-var ,height) - (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-char)) ,y-var))) + (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-byte)) ,y-var))) (declare (type pixels-row ,row)) (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) `(dotimes (,,x-var ,',width) (macrolet ((raw-pixel () - `(deref-array ,',',row '(:array :unsigned-char) ,',,x-var))) + `(deref-array ,',',row '(:array :unsigned-byte) ,',,x-var))) (locally ,@,inner-body))))) (locally

1 0

[bknr-cvs] r2428 - in branches/trunk-reorg/thirdparty: cl-gd cl-gd-0.5.6 cl-gd-0.5.6/doc cl-gd-0.5.6/test cl-gd-0.5.6/test/orig
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:22:39 2008 New Revision: 2428 Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/CHANGELOG branches/trunk-reorg/thirdparty/cl-gd-0.5.6/Makefile branches/trunk-reorg/thirdparty/cl-gd-0.5.6/README branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-glue.c branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.asd branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors-aux.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/anti-aliased-lines.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/brushed-arc.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/chart.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/clipped-tangent.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/demooutp.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/gddemo.c branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/index.html branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/smallzappa.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/strings.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/triangle.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-ellipse.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-green.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/drawing.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/gd-uffi.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/images.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/init.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/packages.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/specials.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/strings.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/demoin.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/anti-aliased-lines.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/brushed-arc.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/chart.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/circle.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/clipped-tangent.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/triangle.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-ellipse.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-green.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/smallzappa.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/zappa.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/transform.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/util.lisp Removed: branches/trunk-reorg/thirdparty/cl-gd/ Log: Update cl-gd. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/CHANGELOG ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/CHANGELOG Thu Jan 31 05:22:39 2008 @@ -0,0 +1,102 @@ +Version 0.5.6 +2007-07-29 +Make WITH-TRANSFORMATIONS thread-safe (thanks to Alain Picard) + +Version 0.5.5 +2007-04-24 +Ugh, fix the fix once more (again thanks to Jong-won Choi) + +Version 0.5.4 +2007-04-06 +Trying to fix the 0.5.3 fix... (bug reported by Jong-won Choi) + +Version 0.5.3 +2007-03-19 +Fixed bug in DRAW-FREETYPE-STRING (reported by Andrei Stebakov) + +Version 0.5.2 +2007-02-28 +Fix CONVERT-TO-CHAR-REFERENCES (bug caught by Luo Yong) +Documentation fixes (thanks to Yoni Rabkin Katzenell) + +Version 0.5.1 +2005-10-04 +Support for OpenMCL via CFFI (thanks to Bryan O'Connor) + +Version 0.5.0 +2005-09-26 +Experimental CLISP/CFFI support (thanks to Luis Oliveira) +Don't redefine what's already there (for LispWorks) + +Version 0.4.8 +2005-05-17 +Re-enabled the ability to build without GIF support + +Version 0.4.7 +2005-05-07 +Added GET-PIXEL (provided by Alan Shields) + +Version 0.4.6 +2005-03-31 +Fixed typo in WITH-IMAGE* (thanks to Peter Barabas) +Handle CMUCL search lists correctly (thanks to Hans H�bner) +Added -lc option to linker call and included makefile (thanks to Hans H�bner) + +Version 0.4.5 +2005-03-16 +Fixed type check in MAKE-STREAM-FN (thanks to Walter C. Pelissero) + +Version 0.4.4 +2005-03-09 +More bug fixes (thanks to Carlos Ungil) + +Version 0.4.3 +2005-03-09 +Some bug fixes (thanks to Carlos Ungil) + +Version 0.4.2 +2004-11-26 +Build GIF support by default +Added link to cl-gd-glue.dll for Windows and corresponding documentation +Updated files in test/orig + +Version 0.4.1 +2004-05-21 +Replaced WRITE-BYTE with WRITE-SEQUENCE for LispWorks - see <http://article.gmane.org/gmane.lisp.lispworks.general/1827> + +Version 0.3.1 +2004-04-25 +Two separate C source files (with and without GIF support) +Added note about failed tests +Added hyperdoc support +Added :CL-GD to *FEATURES* + +Version 0.3.0 +2004-03-29 +Added GIF support (thanks to Hans H�bner) +Added Gentoo link + +Version 0.2.0 +2003-10-26 +Added DO-PIXELS and friends (proposed by Kevin Rosenberg) +Added Debian link + +Version 0.1.4 +2003-08-29 +Added library path for Debian compatibility (thanks to Kevin Rosenberg) + +Version 0.1.3 +2003-08-29 +Make CL-GD-TEST output less verbose for SBCL (thanks to Christophe Rhodes) + +Version 0.1.2 +2003-08-28 +Changed WITH-TRANSFORMATION macro to keep SBCL from complaining (thanks to Christophe Rhodes) + +Version 0.1.1 +2003-08-28 +Fixed *NULL-IMAGE* bug in DRAW-FREETYPE-STRING + +Version 0.1.0 +2003-08-26 +Initial release Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/Makefile Thu Jan 31 05:22:39 2008 @@ -0,0 +1,11 @@ +# this should work for FreeBSD and most Linux distros + +cl-gd-glue.so: + gcc -I/usr/local/include -fPIC -c cl-gd-glue.c + ld -shared -lgd -lz -lpng -ljpeg -lfreetype -liconv -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib + rm cl-gd-glue.o + +# this should work for Mac OS X + +cl-gd-glue.dylib: + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/README Thu Jan 31 05:22:39 2008 @@ -0,0 +1,69 @@ +Complete documentation for CL-GD can be found in the 'doc' +directory. + +CL-GD also supports Nikodemus Siivola's HYPERDOC, see +<http://common-lisp.net/project/hyperdoc/> and +<http://www.cliki.net/hyperdoc>. + +1. Installation (see doc/index.html for Windows instructions) + +1.1. Download and install a recent version of asdf. + +1.2. Download and install UFFI. CL-GD needs at least version 1.3.4 of + UFFI to work properly. However, as of August 2003, only + AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported + because CL-GD needs the new UFFI macros WITH-CAST-POINTER and + DEF-FOREIGN-VAR which haven't yet been ported to all UFFI + platforms. + +1.3. Download and install a recent version of GD and its supporting + libraries libpng, zlib, libjpeg, libiconv, and libfreetype. CL-GD has + been tested with GD 2.0.33, versions older than 2.0.28 won't + work. Note that you won't be able to compile CL-GD unless you have + installed all supporting libraries. This is different from using + GD directly from C where you only have to install the libraries + you intend to use. + +1.4. Unzip and untar the file cl-gd.tgz and put the resulting + directory wherever you want, then cd into this directory. + +1.5. Compile cl-gd-glue.c into a shared library for your platform. On + Linux this would be + + gcc -fPIC -c cl-gd-glue.c + ld -lgd -lz -lpng -ljpeg -lfreetype -lm -liconv -shared cl-gd-glue.o -o cl-gd-glue.so + rm cl-gd-glue.o + + For Mac OS X, use + + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib + +1.6. Make sure that cl-gd.asd can be seen from asdf (this is usually + achieved by a symbolic link), start your favorite Lisp, and compile + CL-GD: + + (asdf:oos 'asdf:compile-op :cl-gd) + + From now on you can simply load CL-GD into a running Lisp image + with + + (asdf:oos 'asdf:load-op :cl-gd) + +2. Test + +CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then + + (asdf:oos 'asdf:load-op :cl-gd-test) + (cl-gd-test:test) + +If you have the georgiab.ttf TrueType font from Microsoft you can also +check the FreeType support of CL-GD with + + (cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") + +where you should obviously replace the path above with the full path +to the font on your machine. + +(See the note about failed tests in the documentation.) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-glue.c ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-glue.c Thu Jan 31 05:22:39 2008 @@ -0,0 +1,187 @@ +/* Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE + GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + +#include <errno.h> +#include <stdio.h> +#include "gd.h" + +gdImagePtr gdImageCreateFromJpegFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromJpeg(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +#ifndef GD_DONT_USE_GIF +gdImagePtr gdImageCreateFromGifFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGif(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} +#endif + +gdImagePtr gdImageCreateFromPngFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromPng(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGdFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2File (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2PartFile (char *filename, int *err, int srcX, int srcY, int w, int h) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2Part(in, srcX, srcY, w, h); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromXbmFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromXbm(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +int gdImageGetAlpha (gdImagePtr im, int color) { + return gdImageAlpha(im, color); +} + +int gdImageGetRed (gdImagePtr im, int color) { + return gdImageRed(im, color); +} + +int gdImageGetGreen (gdImagePtr im, int color) { + return gdImageGreen(im, color); +} + +int gdImageGetBlue (gdImagePtr im, int color) { + return gdImageBlue(im, color); +} + +int gdImageGetSX (gdImagePtr im) { + return gdImageSX(im); +} + +int gdImageGetSY (gdImagePtr im) { + return gdImageSY(im); +} + +int gdImageGetColorsTotal (gdImagePtr im) { + return gdImageColorsTotal(im); +} + +/* dumb names, I know... */ +int gdImageGetGetInterlaced (gdImagePtr im) { + return gdImageGetInterlaced(im); +} + +int gdImageGetGetTransparent (gdImagePtr im) { + return gdImageGetTransparent(im); +} Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.asd Thu Jan 31 05:22:39 2008 @@ -0,0 +1,45 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.11 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd-test.system + (:use :cl :asdf)) + +(in-package :cl-gd-test.system) + +(defparameter *cl-gd-test-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd-test + :version "0.4.8" + :components ((:file "cl-gd-test")) + :depends-on (:cl-gd)) + Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,490 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.26 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage #:cl-gd-test + (:use #:cl + #:cl-gd) + (:export #:test)) + +(in-package :cl-gd-test) + +(defparameter *test-directory* + (merge-pathnames (make-pathname :directory '(:relative "test")) + (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + + "Where test files are put.") + +(defun test-file-location (name &optional (type :unspecific)) + "Create test file location from NAME and TYPE component." + (make-pathname :name name + :type type + :defaults *test-directory*)) + +(defun compare-files (file &key type expected-result) + "Compare test file FILE to orginal file in subdirectory ORIG." + (with-image-from-file (image file) + (with-image-from-file (orig (merge-pathnames + (make-pathname :type + (or type (pathname-type file)) + :directory + '(:relative "orig")) + file)) + (equal (differentp image orig) + expected-result)))) + +(defun test-001 () + (let ((file (test-file-location "one-pixel" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-002 () + (let ((file (test-file-location "one-pixel" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-003 () + (let ((file (test-file-location "one-line" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-004 () + (let ((file (test-file-location "one-line" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing PNG file + (compare-files file))) + +(defun test-005 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (let ((num (number-of-colors))) + (find-color 255 255 255 :resolve t) + (multiple-value-bind (width height) + (image-size) + (and (= width 40) + (= height 40) + ;; FIND-COLOR should not have changed the number of + ;; colors + (= num (number-of-colors))))))) + +(defun test-006 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (with-transformation (:x1 0.1 :x2 0.5 :y1 10.8 :y2 20.9) + (multiple-value-bind (width height) + (image-size) + ;; make sure WITH-TRANSFORMATION returns transformed size + (and (>= 0.0001 (abs (- 0.4 width))) + (>= 0.0001 (abs (- 10.1 height)))))))) + +(defun test-007 () + (let ((file (test-file-location "circle" "png"))) + (with-image* (40 40) + (allocate-color 255 255 255) + (let ((black (allocate-color 0 0 0))) + (with-default-color (black) + ;; move origin to center and stretch + (with-transformation (:x1 -100 :width 200 :y1 -100 :height 200) + (draw-filled-circle 0 0 50) + (write-image-to-file file + :if-exists :supersede))))) + (compare-files file))) + +(defun test-008 () + (with-image (image 40 40) + (allocate-color 255 255 255 :image image) + (with-default-color ((allocate-color 0 0 0 :image image)) + ;; no transformation and use more general ellipse function + (draw-filled-ellipse 20 20 20 20 :image image) + (with-image-from-file (other-image + (test-file-location "circle" "png")) + (not (differentp image other-image)))))) + +(defun test-009 () + (let ((file (test-file-location "chart" "png"))) + ;; create 200x200 pixel image + (with-image* (200 200) + ;; background color + (allocate-color 68 70 85) + (let ((beige (allocate-color 222 200 81)) + (brown (allocate-color 206 150 75)) + (green (allocate-color 104 156 84)) + (red (allocate-color 163 83 84)) + (white (allocate-color 255 255 255)) + (two-pi (* 2 pi))) + ;; move origin to center of image + (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) + ;; draw some 'pie slices' + (draw-arc 0 0 130 130 0 (* .6 two-pi) + :center-connect t :filled t :color beige) + (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) + :center-connect t :filled t :color brown) + (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) + :center-connect t :filled t :color green) + (draw-arc 0 0 130 130 (* .95 two-pi) two-pi + :center-connect t :filled t :color red) + ;; use GD fonts + (with-default-color (white) + (with-default-font (:small) + (draw-string -8 -30 "60%") + (draw-string -20 40 "20%") + (draw-string 20 30 "15%")) + (draw-string -90 90 "Global Revenue" + :font :large)) + (write-image-to-file file + :compression-level 6 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-010 () + (let ((file (test-file-location "zappa-green" "jpg"))) + ;; get JPEG from disk + (with-image-from-file (old (test-file-location "zappa" "jpg")) + (multiple-value-bind (width height) + (image-size old) + (with-image (new width height) + ;; green color for background + (allocate-color 0 255 0 :image new) + ;; merge with original JPEG + (copy-image old new 0 0 0 0 width height + :merge 50) + (write-image-to-file file + :image new + :if-exists :supersede)))) + (compare-files file))) + +(defun test-011 () + ;; small image + (with-image* (10 10) + (loop for i below +max-colors+ do + ;; allocate enough colors (all gray) to fill the palette + (allocate-color i i i)) + (and (= +max-colors+ (number-of-colors)) + (null (find-color 255 0 0 :exact t)) + (let ((match (find-color 255 0 0))) ; green + (and (= 85 + (color-component :red match) + (color-component :green match) + (color-component :blue match))))))) + +(defun test-012 () + (let ((file (test-file-location "triangle" "png"))) + (with-image* (100 100) + (allocate-color 255 255 255) ; white background + (let ((red (allocate-color 255 0 0)) + (yellow (allocate-color 255 255 0)) + (orange (allocate-color 255 165 0))) + ;; thin black border + (draw-rectangle* 0 0 99 99 + :color (allocate-color 0 0 0)) + ;; lines are five pixels thick + (with-thickness (5) + ;; colored triangle + (draw-polygon (list 10 10 90 50 50 90) + ;; styled color + :color (list red red red + yellow yellow yellow + nil nil nil + orange orange orange)) + (write-image-to-file file + :compression-level 8 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-013 () + (let ((file (test-file-location "brushed-arc" "png"))) + (with-image* (200 100) + (allocate-color 255 165 0) ; orange background + (with-image (brush 6 6) + (let* ((black (allocate-color 0 0 0 :image brush)) ; black background + (red (allocate-color 255 0 0 :image brush)) + (blue (allocate-color 0 0 255 :image brush))) + (setf (transparent-color brush) black) ; make background transparent + ;; now set the pixels in the brush + (set-pixels '(2 2 2 3 3 2 3 3) + :color blue :image brush) + (set-pixels '(1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) + :color red :image brush) + ;; then use it to draw an arc + (draw-arc 100 50 180 80 180 300 :color (make-brush brush))) + (write-image-to-file file + :compression-level 7 + :if-exists :supersede))) + (compare-files file))) + +(defun test-014 () + (let ((file (test-file-location "anti-aliased-lines" "png"))) + (with-image* (150 50) + (let ((orange (allocate-color 255 165 0)) ; orange background + (white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0))) + ;; white background rectangle in the middle third + (draw-rectangle* 50 0 99 49 + :filled t + :color white) + (with-thickness (2) + ;; just a red line + (draw-line 5 10 145 10 :color red) + ;; anti-aliased red line + (draw-line 5 25 145 25 :color (make-anti-aliased red)) + ;; anti-aliased red line which should stand out against + ;; orange background + (draw-line 5 40 145 40 :color (make-anti-aliased red orange)))) + (write-image-to-file file + :compression-level 3 + :if-exists :supersede)) + (compare-files file))) + +(defun test-015 () + (let ((file (test-file-location "clipped-tangent" "png"))) + (with-image* (150 150) + (allocate-color 255 255 255) ; white background + ;; transform such that x axis ranges from (- PI) to PI and y + ;; axis ranges from -3 to 3 + (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) + (let ((black (allocate-color 0 0 0)) + (red (allocate-color 255 0 0)) + (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) + (with-default-color (black) + ;; draw axes + (draw-line 0 -3 0 3 :color black) + (draw-line (- pi) 0 pi 0)) + ;; show clipping rectangle (styled) + (draw-rectangle rectangle :color (list black black black nil black nil)) + (with-clipping-rectangle (rectangle) + ;; draw tangent function + (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do + (set-pixel x (tan x) :color red))))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun gd-demo-picture (file random-state &optional write-file) + (with-image* ((+ 256 384) 384 t) + (let ((white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0)) + (green (allocate-color 0 255 0)) + (blue (allocate-color 0 0 255)) + (vertices (list 64 0 0 128 128 128)) + (image-width (image-width)) + (image-height (image-height))) + (setf (transparent-color) white) + (draw-rectangle* 0 0 image-width image-height :color white) + (with-image-from-file (in-file (test-file-location "demoin" "png")) + (copy-image in-file *default-image* + 0 0 32 32 192 192 + :resize t + :dest-width 255 + :dest-height 255 + :resample t) + (multiple-value-bind (in-width in-height) + (image-size in-file) + (loop for a below 360 by 45 do + (copy-image in-file *default-image* + 0 0 + (+ 256 192 (* 128 (cos (* a .0174532925)))) + (- 192 (* 128 (sin (* a .0174532925)))) + in-width in-height + :rotate t + :angle a)) + (with-default-color (green) + (with-thickness (4) + (draw-line 16 16 240 16) + (draw-line 240 16 240 240) + (draw-line 240 240 16 240) + (draw-line 16 240 16 16)) + (draw-polygon vertices :filled t)) + (dotimes (i 3) + (incf (nth (* 2 i) vertices) 128)) + (draw-polygon vertices + :color (make-anti-aliased green) + :filled t) + (with-default-color (blue) + (draw-arc 128 128 60 20 0 720) + (draw-arc 128 128 40 40 90 270) + (fill-image 8 8)) + (with-image (brush 16 16 t) + (copy-image in-file brush + 0 0 0 0 + in-width in-height + :resize t + :dest-width (image-width brush) + :dest-height (image-height brush)) + (draw-line 0 255 255 0 + :color (cons (make-brush brush) + (list nil nil nil nil nil nil nil t)))))) + (with-default-color (red) + (draw-string 32 32 "hi" :font :giant) + (draw-string 64 64 "hi" :font :small)) + (with-clipping-rectangle* (0 (- image-height 100) 100 image-height) + (with-default-color ((make-anti-aliased white)) + (dotimes (i 100) + (draw-line (random image-width random-state) + (random image-height random-state) + (random image-width random-state) + (random image-height random-state)))))) + (setf (interlacedp) t) + (true-color-to-palette) + (if write-file + (write-image-to-file file + :if-exists :supersede) + (with-image-from-file (demo-file file) + (not (differentp demo-file *default-image*)))))) + +(defun test-016 () + (let* ((file (test-file-location "demooutp" "png")) + (random-state-1 (make-random-state t)) + (random-state-2 (make-random-state random-state-1))) + (gd-demo-picture file random-state-1 t) + (gd-demo-picture file random-state-2))) + +(defun test-017 () + (let ((file (test-file-location "zappa-ellipse" "png"))) + (with-image* (250 150) + (with-image-from-file (zappa (test-file-location "smallzappa" "png")) + (setf (transparent-color) (allocate-color 255 255 255)) + (draw-filled-ellipse 125 75 250 150 + :color (make-tile zappa))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun test-018 () + (let (result) + (with-image* (3 3) + (allocate-color 255 255 255) + (draw-line 0 0 2 2 :color (allocate-color 0 0 0)) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 1) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 1) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 1)))))) + +(defun test-019 () + (let (result) + (with-image* (3 3 t) + (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) + (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) + (do-pixels () + (unless (zerop (raw-pixel)) + (decf (raw-pixel) #xff))) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 #xffff00) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 #xffff00) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 #xffff00)))))) + +(defun test-020 (georgia) + ;; not used for test suite because of dependency on font + (with-image* (200 200) + ;; set background (white) and make it transparent + (setf (transparent-color) + (allocate-color 255 255 255)) + (loop for angle from 0 to (* 2 pi) by (/ pi 6) + for blue downfrom 255 by 20 do + (draw-freetype-string 100 100 "Common Lisp" + :font-name georgia + :angle angle + ;; note that ALLOCATE-COLOR won't work + ;; here because the anti-aliasing uses + ;; up too much colors + :color (find-color 0 0 blue + :resolve t))) + (write-image-to-file (test-file-location "strings" "png") + :if-exists :supersede))) + +(defun test% (georgia) + (loop for i from 1 to (if georgia 20 19) do + (handler-case + (format t "Test ~A ~:[failed~;succeeded~].~%" i + (let ((test-function + (intern (format nil "TEST-~3,'0d" i) + :cl-gd-test))) + (if (= i 20) + (funcall test-function georgia) + (funcall test-function)))) + (error (condition) + (format t "Test ~A failed with the following error: ~A~%" + i condition))) + (force-output)) + (format t "Done.~%")) + +(defun test (&optional georgia) + #-:sbcl + (test% georgia) + #+:sbcl + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (test% georgia))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd Thu Jan 31 05:22:39 2008 @@ -0,0 +1,58 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.18 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd.system + (:use :cl :asdf) + (:export :*cl-gd-directory*)) + +(in-package :cl-gd.system) + +(defparameter *cl-gd-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd + :version "0.5.6" + :serial t + :components ((:file "packages") + (:file "util") + (:file "specials") + (:file "init") + (:file "gd-uffi") + (:file "transform") + (:file "images") + (:file "colors-aux") + (:file "colors") + (:file "drawing") + (:file "strings") + (:file "misc")) + :depends-on (#-(or :clisp :openmcl) :uffi + #+(or :clisp :openmcl) :cffi-uffi-compat)) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors-aux.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors-aux.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,168 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun current-brush (&optional (image *default-image*)) + "Returns the GD image which is the current brush of IMAGE \(or NIL +if there is no current brush)." + (check-type image image) + (let ((brush (get-slot-value (img image) 'gd-image 'brush))) + (if (null-pointer-p brush) + nil + brush))) + +(defun (setf current-brush) (brush &optional (image *default-image*)) + "Sets BRUSH \(which must be a GD image) to be the current brush +for IMAGE." + (check-type brush image) + (check-type image image) + (gd-image-set-brush (img image) (img brush)) + brush) + +(defun current-tile (&optional (image *default-image*)) + "Returns the GD image which is the current tile of IMAGE \(or NIL +if there is no current tile)." + (check-type image image) + (let ((tile (get-slot-value (img image) 'gd-image 'tile))) + (if (null-pointer-p tile) + nil + tile))) + +(defun (setf current-tile) (tile &optional (image *default-image*)) + "Sets TILE \(which must be a GD image) to be the current tile +for IMAGE." + (check-type tile (or image null)) + (check-type image image) + (gd-image-set-tile (img image) (img tile)) + tile) + +(defun current-style (&optional (image *default-image*)) + "Returns the current style of IMAGE as a list." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop for i below style-length + collect (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))))) + +(defun current-style* (&key (image *default-image*)) + "Returns the current style of IMAGE as an array." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop with result = (make-array style-length) + for i below style-length + do (setf (aref result i) + (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))) + finally (return result)))) + +(defgeneric (setf current-style) (style &optional image) + (:documentation "Sets STYLE to be the current drawing style for +IMAGE. STYLE can be a LIST or a VECTOR. Each element of STYLE is +either a color or NIL \(for transparent pixels).")) + +(defmethod (setf current-style) ((style list) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color in style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defmethod (setf current-style) ((style vector) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color across style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defun set-anti-aliased (color do-not-blend &optional (image *default-image*)) + "Set COLOR to be the current anti-aliased color of +IMAGE. DO-NOT-BLEND \(if provided) is the background color +anti-aliased lines stand out against clearly." + (check-type color integer) + (check-type do-not-blend (or integer null)) + (check-type image image) + (gd-image-set-anti-aliased-do-not-blend (img image) + color + (or do-not-blend -1))) + +(defun resolve-c-color (color image) + "Accepts a CL-GD 'color' COLOR and returns the corresponding +argument for GD, modifying internal slots of IMAGE if needed." + (etypecase color + (brush + (setf (current-brush image) color) + +brushed+) + (tile + (setf (current-tile image) color) + +tiled+) + ((cons brush (or vector list)) + (setf (current-brush image) (car color) + (current-style image) (cdr color)) + +styled-brushed+) + (anti-aliased-color + (set-anti-aliased (color color) + (do-not-blend color) + image) + +anti-aliased+) + ((or vector list) + (setf (current-style image) color) + +styled+) + (integer + color))) + +(defmacro with-color-argument (&body body) + "Internal macro used to give correct color arguments to enclosed +foreign functions. Assumes fixed names COLOR and IMAGE." + (with-unique-names (c-color-arg) + `(let ((,c-color-arg (resolve-c-color color image))) + ,@(sublis (list (cons 'color c-color-arg)) + body :test #'eq)))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,247 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.25 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-color ((color) &body body) + "Executes BODY with *DEFAULT-COLOR* bound to COLOR so that you don't +have to provide the COLOR keyword/optional argument to drawing +functions." + `(let ((*default-color* ,color)) + ,@body)) + +(defun allocate-color (red green blue &key alpha (errorp t) (image *default-image*)) + "Finds the first available color index in the image IMAGE specified, +sets its RGB values to those requested \(255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value +in the case of a true color image. In either case you can then use the +returned value as a COLOR parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If ALPHA +\(not greater than 127) is provided, an RGBA color will always be +allocated. If all +GD-MAX-COLORS+ have already been allocated this +function will, depending on the value of ERRORP, either raise an error +or return NIL." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (let ((result + (if alpha + (gd-image-color-allocate-alpha (img image) red green blue alpha) + (gd-image-color-allocate (img image) red green blue)))) + (cond ((and errorp + (= result -1)) + (error "Can't allocate color")) + ((= result -1) + nil) + (t + result)))) + +(defun deallocate-color (color &optional (image *default-image*)) + "Marks the specified color COLOR as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image IMAGE." + (check-type color integer) + (check-type image image) + (gd-image-color-deallocate (img image) color)) + +(defun transparent-color (&optional (image *default-image*)) + "Returns the transparent color of IMAGE \(or NIL if there is none)." + (check-type image image) + (gd-image-get-transparent (img image))) + +(defun (setf transparent-color) (color &optional (image *default-image*)) + "Makes COLOR the transparent color of IMAGE. If COLOR is NIL the +image won't have a transparent color. Note that JPEG images don't +support transparency." + (check-type color (or null integer)) + (check-type image image) + (gd-image-color-transparent (img image) (or color -1)) + color) + +(defun true-color-p (&optional (image *default-image*)) + "Returns true iff IMAGE is a true color image." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'true-color)))) + +(defun number-of-colors (&key (image *default-image*)) + "Returns the number of color allocated in IMAGE. Returns NIL if +IMAGE is a true color image." + (check-type image image) + (if (true-color-p image) + nil + (get-slot-value (img image) 'gd-image 'colors-total))) + +(defun find-color (red green blue &key alpha exact hwb resolve (image *default-image*)) + "Tries to find and/or allocate a color from IMAGE's color +palette. If EXACT is true, the color will only be returned if it is +already allocated. If EXACT is NIL, a color which is 'close' to the +color specified by RED, GREEN, and BLUE \(and probably ALPHA) might be +returned \(unless there aren't any colors allocated in the image +yet). If HWB is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If RESOLVE is true a color \(probably a new one) will +always be returned, otherwise the result of this function might be +NIL. If ALPHA \(not greater than 127) is provided, an RGBA color (or +NIL) will be returned. + +ALPHA, EXACT, and HWB are mutually exclusive. RESOLVE can't be used +together with EXACT or HWB." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (when (< 1 (count-if #'identity (list alpha exact hwb))) + (error "You can't specify two of ALPHA, EXACT, and HWB at the same +time")) + (when (and hwb resolve) + (error "You can't specify HWB and RESOLVE at the same time")) + (when (and exact resolve) + (error "You can't specify EXACT and RESOLVE at the same time")) + (let ((result + (cond ((and resolve alpha) + (gd-image-color-resolve-alpha (img image) red green blue alpha)) + (resolve + (gd-image-color-resolve (img image) red green blue)) + (alpha + (gd-image-color-closest-alpha (img image) red green blue alpha)) + (exact + (gd-image-color-exact (img image) red green blue)) + (hwb + (gd-image-color-closest-hwb (img image) red green blue)) + (t + (gd-image-color-closest (img image) red green blue))))) + (if (= result -1) + nil + result))) + +(defun thickness (&optional (image *default-image*)) + "Gets the width of lines drawn by the drawing functions. Note that +this is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type image image) + (get-slot-value (img image) 'gd-image 'thick)) + +(defun (setf thickness) (thickness &optional (image *default-image*)) + "Sets the width of lines drawn by the drawing functions. Note that +THICKNESS is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type thickness integer) + (check-type image image) + (gd-image-set-thickness (img image) thickness) + thickness) + +(defmacro with-thickness ((thickness &key (image '*default-image*)) &body body) + "Executes BODY with the current line width of IMAGE set to +THICKNESS. The image's previous line width is guaranteed to be +restored before the macro exits. Note that the line width is measured +in pixels and is not affected by WITH-TRANSFORMATION." + (with-unique-names (old-thickness) + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (thickness image) + `(let ((,old-thickness (thickness ,image))) + (unwind-protect + (progn + (setf (thickness ,image) ,thickness)) + ,@body) + (setf (thickness ,image) ,old-thickness))))) + +(defun alpha-blending-p (&optional (image *default-image*)) + "Returns whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(return value is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(return value is true). This is +only meaningful for true color images." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'alpha-blending-flag)))) + +(defun (setf alpha-blending-p) (blending &optional (image *default-image*)) + "Determines whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(if BLENDING is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(if BLENDING is true). This is +only meaningful for true color images." + (check-type image image) + (gd-image-alpha-blending (img image) (if blending 1 0)) + blending) + +(defun save-alpha-p (&optional (image *default-image*)) + "Returns whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) + +(defun (setf save-alpha-p) (save &key (image *default-image*)) + "Determines whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (gd-image-save-alpha (img image) (if save 1 0)) + save) + +(defun color-component (component color &key (image *default-image*)) + "Returns the specified color component of COLOR. COMPONENT can be +one of :RED, :GREEN, :BLUE, and :ALPHA." + (check-type color integer) + (check-type image image) + (funcall (ecase component + ((:red) #'gd-image-get-red) + ((:green) #'gd-image-get-green) + ((:blue) #'gd-image-get-blue) + ((:alpha) #'gd-image-get-alpha)) + (img image) + color)) + +(defun color-components (color &key (image *default-image*)) + "Returns a list of the color components of COLOR. The +components are in the order red, green, blue, alpha." + (mapcar #'(lambda (c) (color-component c color :image image)) + '(:red :green :blue :alpha))) + +(defun find-color-from-image (color source-image &key alpha exact hwb + resolve (image *default-image*)) + "Returns the color in IMAGE corresponding to COLOR in +SOURCE-IMAGE. The keyword parameters are passed to FIND-COLOR." + (let ((red (color-component :red color + :image source-image)) + (blue (color-component :blue color + :image source-image)) + (green (color-component :green color + :image source-image)) + (alpha (when alpha + (color-component :alpha color + :image source-image)))) + (find-color red green blue + :alpha alpha + :exact exact + :hwb hwb + :resolve resolve + :image image))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/brushed-arc.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/chart.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/demooutp.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/gddemo.c ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/gddemo.c Thu Jan 31 05:22:39 2008 @@ -0,0 +1,169 @@ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include <stdio.h> +#include <math.h> +#include <stdlib.h> +#include "gd.h" +#include "gdfontg.h" +#include "gdfonts.h" + +int +main (void) +{ +#ifdef HAVE_LIBPNG + /* Input and output files */ + FILE *in; + FILE *out; + + /* Input and output images */ + gdImagePtr im_in = 0, im_out = 0; + + /* Brush image */ + gdImagePtr brush; + + /* Color indexes */ + int white; + int blue; + int red; + int green; + + /* Points for polygon */ + gdPoint points[3]; + int i; + + /* Create output image, in true color. */ + im_out = gdImageCreateTrueColor (256 + 384, 384); + /* 2.0.2: first color allocated would automatically be background in a + palette based image. Since this is a truecolor image, with an + automatic background of black, we must fill it explicitly. */ + white = gdImageColorAllocate (im_out, 255, 255, 255); + gdImageFilledRectangle (im_out, 0, 0, gdImageSX (im_out), + gdImageSY (im_out), white); + + /* Set transparent color. */ + gdImageColorTransparent (im_out, white); + + /* Try to load demoin.png and paste part of it into the + output image. */ + in = fopen ("demoin.png", "rb"); + if (!in) + { + fprintf (stderr, "Can't load source image; this demo\n"); + fprintf (stderr, "is much more impressive if demoin.png\n"); + fprintf (stderr, "is available.\n"); + im_in = 0; + } + else + { + int a; + im_in = gdImageCreateFromPng (in); + fclose (in); + /* Now copy, and magnify as we do so */ + gdImageCopyResampled (im_out, im_in, 32, 32, 0, 0, 192, 192, 255, 255); + /* Now display variously rotated space shuttles in a circle of our own */ + for (a = 0; (a < 360); a += 45) + { + int cx = cos (a * .0174532925) * 128; + int cy = -sin (a * .0174532925) * 128; + gdImageCopyRotated (im_out, im_in, + 256 + 192 + cx, 192 + cy, + 0, 0, gdImageSX (im_in), gdImageSY (im_in), a); + } + } + red = gdImageColorAllocate (im_out, 255, 0, 0); + green = gdImageColorAllocate (im_out, 0, 255, 0); + blue = gdImageColorAllocate (im_out, 0, 0, 255); + /* Fat Rectangle */ + gdImageSetThickness (im_out, 4); + gdImageLine (im_out, 16, 16, 240, 16, green); + gdImageLine (im_out, 240, 16, 240, 240, green); + gdImageLine (im_out, 240, 240, 16, 240, green); + gdImageLine (im_out, 16, 240, 16, 16, green); + gdImageSetThickness (im_out, 1); + /* Circle */ + gdImageArc (im_out, 128, 128, 60, 20, 0, 720, blue); + /* Arc */ + gdImageArc (im_out, 128, 128, 40, 40, 90, 270, blue); + /* Flood fill: doesn't do much on a continuously + variable tone jpeg original. */ + gdImageFill (im_out, 8, 8, blue); + /* Polygon */ + points[0].x = 64; + points[0].y = 0; + points[1].x = 0; + points[1].y = 128; + points[2].x = 128; + points[2].y = 128; + gdImageFilledPolygon (im_out, points, 3, green); + /* 2.0.12: Antialiased Polygon */ + gdImageSetAntiAliased (im_out, green); + for (i = 0; (i < 3); i++) + { + points[i].x += 128; + } + gdImageFilledPolygon (im_out, points, 3, gdAntiAliased); + /* Brush. A fairly wild example also involving a line style! */ + if (im_in) + { + int style[8]; + brush = gdImageCreateTrueColor (16, 16); + gdImageCopyResized (brush, im_in, + 0, 0, 0, 0, + gdImageSX (brush), gdImageSY (brush), + gdImageSX (im_in), gdImageSY (im_in)); + gdImageSetBrush (im_out, brush); + /* With a style, so they won't overprint each other. + Normally, they would, yielding a fat-brush effect. */ + style[0] = 0; + style[1] = 0; + style[2] = 0; + style[3] = 0; + style[4] = 0; + style[5] = 0; + style[6] = 0; + style[7] = 1; + gdImageSetStyle (im_out, style, 8); + /* Draw the styled, brushed line */ + gdImageLine (im_out, 0, 255, 255, 0, gdStyledBrushed); + } + /* Text (non-truetype; see gdtestft for a freetype demo) */ + gdImageString (im_out, gdFontGiant, 32, 32, (unsigned char *) "hi", red); + gdImageStringUp (im_out, gdFontSmall, 64, 64, (unsigned char *) "hi", red); + /* Random antialiased lines; coordinates all over the image, + but the output will respect a small clipping rectangle */ + gdImageSetClip(im_out, 0, gdImageSY(im_out) - 100, + 100, gdImageSY(im_out)); + /* Fixed seed for reproducibility of results */ + srand(100); + for (i = 0; (i < 100); i++) { + int x1 = rand() % gdImageSX(im_out); + int y1 = rand() % gdImageSY(im_out); + int x2 = rand() % gdImageSX(im_out); + int y2 = rand() % gdImageSY(im_out); + gdImageSetAntiAliased(im_out, white); + gdImageLine (im_out, x1, y1, x2, y2, gdAntiAliased); + } + /* Make output image interlaced (progressive, in the case of JPEG) */ + gdImageInterlace (im_out, 1); + out = fopen ("demoout.png", "wb"); + /* Write PNG */ + gdImagePng (im_out, out); + fclose (out); + /* 2.0.12: also write a paletteized version */ + out = fopen ("demooutp.png", "wb"); + gdImageTrueColorToPalette (im_out, 0, 256); + gdImagePng (im_out, out); + fclose (out); + gdImageDestroy (im_out); + if (im_in) + { + gdImageDestroy (im_in); + } +#else + fprintf (stderr, "No PNG library support.\n"); +#endif /* HAVE_LIBPNG */ + return 0; +} Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/index.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/index.html Thu Jan 31 05:22:39 2008 @@ -0,0 +1,1441 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<html> + +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <title>CL-GD - Use the GD Graphics library from Common Lisp</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + h3, h4 { text-decoration: underline; } + a { text-decoration: none; padding: 1px 2px 1px 2px; } + a:visited { text-decoration: none; padding: 1px 2px 1px 2px; } + a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } + a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; } + a.none { text-decoration: none; padding: 0; } + a.none:visited { text-decoration: none; padding: 0; } + a.none:hover { text-decoration: none; border: none; padding: 0; } + a.none:focus { text-decoration: none; border: none; padding: 0; } + a.noborder { text-decoration: none; padding: 0; } + a.noborder:visited { text-decoration: none; padding: 0; } + a.noborder:hover { text-decoration: none; border: none; padding: 0; } + a.noborder:focus { text-decoration: none; border: none; padding: 0; } + pre.none { padding:5px; background-color:#ffffff } + </style> +</head> + +<body bgcolor=white> + +<h2>CL-GD - Use the GD Graphics library from Common Lisp</h2> + +<blockquote> +   <h3>Abstract</h3> + +CL-GD is a library for Common Lisp which provides an interface to the +<a href="http://www.boutell.com/gd/">GD Graphics Library</a> for the +dynamic creation of images. It is based on <a +href="http://uffi.b9.com/">UFFI</a> and should thus be portable to all +CL implementations supported by UFFI. + +A version which also works with CLISP is available from <a +href="http://ungil.com/cl-gd-clisp.tgz">http://ungil.com/cl-gd-clisp.tgz</a> +thanks to Carlos Ungil. Also, beginning from version 0.5.0/0.5.1, CL-GD +contains initial code to support CLISP and OpenMCL via <a +href="http://common-lisp.net/project/cffi/">CFFI</a> (<a href="http://common-lisp.net/pipermail/cl-gd-devel/2005-September/000030.html">thanks to Luis +Oliveira</a> and Bryan O'Connor). Please try it and report to <a href="#mail">the mailing list</a> if you +have problems. + +The focus of CL-GD is convenience and correctness, not necessarily speed. If you think CL-GD is too slow and you're concerned about speed, <a href="#mail">contact me</a> before you start coding in C... :) + +CL-GD comes with a <a +href="http://www.opensource.org/licenses/bsd-license.php">BSD-style +license</a> so you can basically do with it whatever you want. Please send bug reports to <a href="#mail">the mailing list</a> mentioned below if you encounter any problems with CL-GD. (I'm glad to fix CL-GD but I can't do much about GD, of course. So if CL-GD basically works for you but you encounter seemingly strange behaviour when drawing please try if and how you can achieve the intended result with GD directly. That would help me a lot. Thanks.) + +CL-GD is used by <a href="http://www.quickhoney.com/">QuickHoney</a>. + + +Download shortcut: <a href="http://weitz.de/files/cl-gd.tar.gz">http://weitz.de/files/cl-gd.tar.gz</a>. +</blockquote> + +   <h3><a href="#contents" name="example" class=none>A simple example</a></h3> + +The image to the right was created with this piece of code: + +<pre> +<img alt="chart.png" title="chart.png" align=right border=0 vspace=10 hspace=10 width=200 height=200 src="chart.png">(<a class=noborder href="#with-image*">with-image*</a> (200 200) ; create 200x200 pixel image + (<a class=noborder href="#allocate-color">allocate-color</a> 68 70 85) ; background color + (let ((beige (allocate-color 222 200 81)) + (brown (allocate-color 206 150 75)) + (green (allocate-color 104 156 84)) + (red (allocate-color 163 83 84)) + (white (allocate-color 255 255 255)) + (two-pi (* 2 pi))) + ;; move origin to center of image + (<a class=noborder href="#with-transformation">with-transformation</a> (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) + ;; draw some 'pie slices' + (<a class=noborder href="#draw-arc">draw-arc</a> 0 0 130 130 0 (* .6 two-pi) + :center-connect t :filled t :color beige) + (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) + :center-connect t :filled t :color brown) + (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) + :center-connect t :filled t :color green) + (draw-arc 0 0 130 130 (* .95 two-pi) two-pi + :center-connect t :filled t :color red) + (<a class=noborder href="#with-default-color">with-default-color</a> (white) + (<a class=noborder href="#with-default-font">with-default-font</a> (:small) + (<a class=noborder href="#draw-string">draw-string</a> -8 -30 "60%") + (draw-string -20 40 "20%") + (draw-string 20 30 "15%")) + (<a class=noborder href="#draw-freetype-string">draw-freetype-string</a> -90 75 "Global Revenue" + ;; this assumes that 'DEFAULT_FONTPATH' + ;; is set correctly + :font-name "verdanab")))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "chart.png" + :compression-level 6 :if-exists :supersede)) +</pre> + + +See below for more examples. + +   <h3><a class=none name="contents">Contents</a></h3> +<ul> + <li><a href="#example">A simple example</a> + <li><a href="#install">Download and installation</a> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#images">Images</a> + <ul> + <li><a href="#create-image"><code>create-image</code></a> + <li><a href="#create-image-from-file"><code>create-image-from-file</code></a> + <li><a href="#create-image-from-gd2-part"><code>create-image-from-gd2-part</code></a> + <li><a href="#destroy-image"><code>destroy-image</code></a> + <li><a href="#with-image"><code>with-image</code></a> + <li><a href="#with-image-from-file"><code>with-image-from-file</code></a> + <li><a href="#with-image-from-gd2-part"><code>with-image-from-gd2-part</code></a> + <li><a href="#default-image"><code>*default-image*</code></a> + <li><a href="#with-default-image"><code>with-default-image</code></a> + <li><a href="#with-image*"><code>with-image*</code></a> + <li><a href="#with-image-from-file*"><code>with-image-from-file*</code></a> + <li><a href="#with-image-from-gd2-part*"><code>with-image-from-gd2-part*</code></a> + <li><a href="#write-jpeg-to-stream"><code>write-jpeg-to-stream</code></a> + <li><a href="#write-png-to-stream"><code>write-png-to-stream</code></a> + <li><a href="#write-wbmp-to-stream"><code>write-wbmp-to-stream</code></a> + <li><a href="#write-gif-to-stream"><code>write-gif-to-stream</code></a> + <li><a href="#write-gd-to-stream"><code>write-gd-to-stream</code></a> + <li><a href="#write-gd2-to-stream"><code>write-gd2-to-stream</code></a> + <li><a href="#write-image-to-stream"><code>write-image-to-stream</code></a> + <li><a href="#write-image-to-file"><code>write-image-to-file</code></a> + <li><a href="#image-width"><code>image-width</code></a> + <li><a href="#image-height"><code>image-height</code></a> + <li><a href="#image-size"><code>image-size</code></a> + </ul> + <li><a href="#colors">Colors</a> + <ul> + <li><a href="#default-color"><code>*default-color*</code></a> + <li><a href="#with-default-color"><code>with-default-color</code></a> + <li><a href="#allocate-color"><code>allocate-color</code></a> + <li><a href="#find-color"><code>find-color</code></a> + <li><a href="#find-color-from-image"><code>find-color-from-image</code></a> + <li><a href="#color-component"><code>color-component</code></a> + <li><a href="#color-components"><code>color-components</code></a> + <li><a href="#deallocate-color"><code>deallocate-color</code></a> + <li><a href="#true-color-p"><code>true-color-p</code></a> + <li><a href="#number-of-colors"><code>number-of-colors</code></a> + <li><a href="#max-colors"><code>+max-colors+</code></a> + <li><a href="#transparent-color"><code>transparent-color</code></a> + <li><a href="#alpha-blending-p"><code>alpha-blending-p</code></a> + <li><a href="#save-alpha-p"><code>save-alpha-p</code></a> + </ul> + <li><a href="#brushes">Styles, brushes, tiles, anti-aliased lines</a> + <ul> + <li><a href="#make-brush"><code>make-brush</code></a> + <li><a href="#make-tile"><code>make-tile</code></a> + <li><a href="#make-anti-aliased"><code>make-anti-aliased</code></a> + </ul> + <li><a href="#transformations">Transformations</a> + <ul> + <li><a href="#with-transformation"><code>with-transformation</code></a> + <li><a href="#without-transformations"><code>without-transformations</code></a> + </ul> + <li><a href="#drawing">Drawing and filling</a> + <ul> + <li><a href="#get-pixel"><code>get-pixel</code></a> + <li><a href="#set-pixel"><code>set-pixel</code></a> + <li><a href="#set-pixels"><code>set-pixels</code></a> + <li><a href="#draw-line"><code>draw-line</code></a> + <li><a href="#draw-rectangle"><code>draw-rectangle</code></a> + <li><a href="#draw-rectangle*"><code>draw-rectangle*</code></a> + <li><a href="#draw-polygon"><code>draw-polygon</code></a> + <li><a href="#draw-filled-circle"><code>draw-filled-circle</code></a> + <li><a href="#draw-filled-ellipse"><code>draw-filled-ellipse</code></a> + <li><a href="#draw-arc"><code>draw-arc</code></a> + <li><a href="#fill-image"><code>fill-image</code></a> + <li><a href="#clipping-rectangle"><code>clipping-rectangle</code></a> + <li><a href="#clipping-rectangle*"><code>clipping-rectangle*</code></a> + <li><a href="#set-clipping-rectangle*"><code>set-clipping-rectangle*</code></a> + <li><a href="#with-clipping-rectangle"><code>with-clipping-rectangle</code></a> + <li><a href="#with-clipping-rectangle*"><code>with-clipping-rectangle*</code></a> + <li><a href="#current-thickness"><code>current-thickness</code></a> + <li><a href="#with-thickness"><code>with-thickness</code></a> + </ul> + <li><a href="#strings">Strings and characters</a> + <ul> + <li><a href="#default-font"><code>*default-font*</code></a> + <li><a href="#with-default-font"><code>with-default-font</code></a> + <li><a href="#draw-character"><code>draw-character</code></a> + <li><a href="#draw-string"><code>draw-string</code></a> + <li><a href="#draw-freetype-string"><code>draw-freetype-string</code></a> + </ul> + <li><a href="#misc">Miscellaneous</a> + <ul> + <li><a href="#do-rows"><code>do-rows</code></a> + <li><a href="#do-pixels-in-row"><code>do-pixels-in-row</code></a> + <li><a href="#do-pixels"><code>do-pixels</code></a> + <li><a href="#raw-pixel"><code>raw-pixel</code></a> + <li><a href="#interlacedp"><code>interlacedp</code></a> + <li><a href="#differentp"><code>differentp</code></a> + <li><a href="#copy-image"><code>copy-image</code></a> + <li><a href="#copy-palette"><code>copy-palette</code></a> + <li><a href="#true-color-to-palette"><code>true-color-to-palette</code></a> + </ul> + <li><a href="#ack">Acknowledgements</a> +</ul> + +   <h3><a href="#contents" name="install" class=none>Download and installation</a></h3> + +CL-GD together with this documentation can be downloaded from <a +href="http://weitz.de/files/cl-gd.tar.gz">http://weitz.de/files/cl-gd.tar.gz</a>. The +current version is 0.5.6. A <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-gd&se…">Debian package</a> is available thanks to <a href="http://pvaneynd.mailworks.org/">Peter van Eynde</a> and <a href="http://b9.com/">Kevin Rosenberg</a>, so if you're on Debian you should have no problems installing CL-GD. There's also a port +for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo Linux</a> thanks to Matthew Kennedy. Otherwise, proceed like this: +<ul> +<li>Download and install a recent version of <a href="http://www.cliki.net/asdf">asdf</a>. +<li>Download and install <a href="http://uffi.b9.com/">UFFI</a>. CL-GD needs at least version 1.3.4 of UFFI to work properly. However, as of August 2003, only AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported because CL-GD needs the new UFFI macros <a href="http://uffi.b9.com/manual/with-cast-pointer.html"><code>WITH-CAST-POINTER</code></a> and <a href="http://uffi.b9.com/manual/def-foreign-var.html"><code>DEF-FOREIGN-VAR</code></a> which haven't yet been ported to all UFFI platforms. Note: For CLISP or OpenMCL download and install <a +href="http://common-lisp.net/project/cffi/">CFFI</a> instead. +<li>Download and install a recent version of <a href="http://www.boutell.com/gd/">GD</a> and its supporting libraries <a href="http://www.libpng.org/pub/png/">libpng</a>, <a href="http://www.info-zip.org/pub/infozip/zlib/">zlib</a>, <a href="http://www.ijg.org/">libjpeg</a>, <a href="http://www.freetype.org/">libfreetype</a>, and maybe <a href="http://www.gnu.org/software/libiconv/">libiconv</a>. CL-GD has been tested and developed with GD 2.0.28, older version probably won't work. Note that you won't be able to compile CL-GD unless you have installed all supporting libraries. This is different from using GD directly from C where you only have to install the libraries you intend to use. +<li>Download <a href="http://weitz.de/files/cl-gd.tar.gz"><code>cl-gd.tar.gz</code></a>, unzip and untar the file and put the resulting directory wherever you want, then cd into this directory. +<li>Compile <code>cl-gd-glue.c</code> into a shared library for your platform. On FreeBSD or Linux this would be +<pre> +gcc -fPIC -c cl-gd-glue.c +ld -lgd -lz -lpng -ljpeg -lfreetype -lm -shared cl-gd-glue.o -o cl-gd-glue.so +rm cl-gd-glue.o +</pre> +(Note: On older versions of Linux, you might have to add <code>-liconv</code>.) + +For Mac OS X, use +<pre> +gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib +</pre> +<li>Make sure that <code>cl-gd.asd</code> can be seen from asdf (this is usually achieved by a symbolic link), start your favorite Lisp, and compile CL-GD: +<pre> +(asdf:oos 'asdf:compile-op :cl-gd) +</pre> +<li>From now on you can simply load CL-GD into a running Lisp image with +<pre> +(asdf:oos 'asdf:load-op :cl-gd) +</pre> +<li>To build without GIF support compile the C library with the option <code>-DGD_DONT_USE_GIF</code> and push the symbol <code>:CL-GD-NO-GIF</code> onto <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v_featur.htm"><code>*FEATURES*</code></a> before compiling CL-GD. + +<li>CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then +<pre> +(asdf:oos 'asdf:load-op :cl-gd-test) +(cl-gd-test:test) +</pre> +If you have the <a +href="http://corefonts.sourceforge.net/"><code>georgiab.ttf</code> +TrueType font from Microsoft</a> you can also check the FreeType +support of CL-GD with +<pre> +(cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") +</pre> +where you should obviously replace the path above with the pull path +to the font on your machine. </ul> + +Note that CL-GD might work correctly even if some of the tests fail +(as long as you don't get error messages). The exact results of the +tests seem to depend on the versions of the C libraries which are +used. + +It is recommended that you at least skim over the <a href="http://www.boutell.com/gd/manual2.0.33.html">original GD documentation</a> before you start using CL-GD. + +Note: If you're on Windows you might want to try this: +<ul> +<li>Download and install the supporting libraries (see above) from <a href="http://gnuwin32.sf.net/">GnuWin32</a> and put the DLLs into a place where your Lisp's FFI will find them. The folder where your Lisp image starts up is usually a good place. +<li>Download the file <code>cl-gd-glue.dll</code> from <a href="http://weitz.de/files/cl-gd-glue.dll">http://weitz.de/files/cl-gd-glue.dll</a> and put it into the CL-GD folder. You don't need to download and install GD itself because it's already integrated into <code>cl-gd-glue.dll</code>. +<li>Start your Lisp and compile CL-GD as described above. +</ul> +This works for me on Windows XP pro SP2 with AllegroCL 6.2 trial as well as with LispWorks 4.3.7 pro. + +Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a> +repository of CL-GD +at <a +href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>. + + +   <h3><a name="mail" class=none>Support and mailing lists</a></h3> + +For questions, bug reports, feature requests, improvements, or patches +please use the <a +href="http://common-lisp.net/mailman/listinfo/cl-gd-devel">cl-gd-devel +mailing list</a>. If you want to be notified about future releases +subscribe to the <a +href="http://common-lisp.net/mailman/listinfo/cl-gd-announce">cl-gd-announce +mailing list</a>. These mailing lists were made available thanks to +the services of <a href="http://common-lisp.net/">common-lisp.net</a>. + +If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>. + +   <h3><a href="#contents" name="images" class=none>Images</a></h3> + +In order to work with CL-GD you first have to create at least one +image - think of it as your canvas, kind of. Images can be +created from scratch or you can load an existing image file from +disk. After you've drawn something or otherwise modified your image +you can write it to a file or a stream. Once you're done with it you +must destroy it to avoid memory leaks. It is recommended that +you use the <code>WITH-IMAGE-</code> macros instead of the +<code>CREATE-IMAGE-</code> functions so you can be sure that images +will always be destroyed no matter what happens. + + [Function] + <a class=none name="create-image">create-image width height <tt>&optional</tt> true-color => image</a> + +<blockquote> +Allocates and returns an image with size <code>width</code> <tt>x</tt> <code>height</code> (in pixels). Creates a true color image if +<code>true-color</code> is true - the default is <code>NIL</code>. You are responsible for +<a href="#destroy-image">destroying</a> the image after you're done with it. It is advisable to use +<a href="#with-image"><code>WITH-IMAGE</code></a> instead. +</blockquote> + + [Function] + <a class=none name="create-image-from-file">create-image-from-file file-name <tt>&optional</tt> type => image</a> + +<blockquote> +Creates an image from the file specified by <code>file-name</code> (which is +either a pathname or a string). The type of the image can be provided +as <code>type</code> (one of the keywords <code>:JPG</code>, <code>:JPEG</code>, <code>:GIF</code>, <code>:PNG</code>, <code>:GD</code>, <code>:GD2</code>, <code>:XBM</code>, or <code>:XPM</code>), or otherwise it will be guessed from the <code>PATHNAME-TYPE</code> of +<code>file-name</code>. You are responsible for <a href="#destroy-image">destroying</a> the image after you're +done with it. It is advisable to use <a href="#with-image-from-file"><code>WITH-IMAGE-FROM-FILE</code></a> instead. +</blockquote> + + [Function] + <a class=none name="create-image-from-gd2-part">create-image-from-gd2-part file-name src-x src-y width height => image</a> + +<blockquote> +Creates an image from the part of the GD2 file specified by <code>file-name</code> (which is +either a pathname or a string) specified by <code>src-x</code>, <code>src-y</code>, <code>width</code>, and <code>height</code>. You are responsible for <a href="#destroy-image">destroying</a> the image after you're +done with it. It is advisable to use <a href="#with-image-from-gd2-part"><code>WITH-IMAGE-FROM-GD2-PART</code></a> instead. +</blockquote> + + [Function] + <a class=none name="destroy-image">destroy-image image => result</a> + +<blockquote> +Destroys (deallocates) <code>image</code> which has been created by <a href="#create-image"><code>CREATE-IMAGE</code></a>, +<a href="#create-image-from-file"><code>CREATE-IMAGE-FROM-FILE</code></a>, or <a href="#create-image-from-gd2-part"><code>CREATE-IMAGE-FROM-GD2-PART</code></a>. <code>result</code> is always <code>NIL</code>. +</blockquote> + + [Macro] + <a class=none name="with-image">with-image (name width height <tt>&optional</tt> true-color) form* => results</a> + +<blockquote> +Creates an image as with <a +href="#create-image"><code>CREATE-IMAGE</code></a> and executes +<code>form*</code> with the image bound to +<code>name</code>. The image is +guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits. +</blockquote> + + [Macro] + <a class=none name="with-image-from-file">with-image-from-file (name file-name <tt>&optional</tt> type) form* => results</a> + +<blockquote> +Creates an image as with <a +href="#create-image-from-file"><code>CREATE-IMAGE-FROM-FILE</code></a> and executes +<code>form*</code> with the image bound to +<code>name</code>. The image is +guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits. +</blockquote> + +<pre> +(<a class=noborder href="#with-image-from-file">with-image-from-file</a> (old "zappa.jpg")<img vspace=10 hspace=10 border=0 alt="zappa-green.jpg" title="zappa-green.jpg" src="zappa-green.jpg" width=150 height=200 align=right><img vspace=10 hspace=10 border=0 alt="zappa.jpg" title="zappa.jpg" src="zappa.jpg" width=150 height=200 align=right> + (multiple-value-bind (width height) + (<a class=noborder href="#image-size">image-size</a> old) + (<a class=noborder href="#with-image">with-image</a> (new width height) + (<a class=noborder href="#allocate-color">allocate-color</a> 0 255 0 :image new) ; green background + (<a class=noborder href="#copy-image">copy-image</a> old new 0 0 0 0 width height + :merge 50) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "zappa-green.jpg" + :image new + :if-exists :supersede)))) +</pre> + + [Macro] + <a class=none name="with-image-from-gd2-part">with-image-from-gd2-part (name file-name src-x src-y width height) form* => results</a> + +<blockquote> +Creates an image as with <a +href="#create-image-from-gd2-part"><code>CREATE-IMAGE-FROM-GD2-PART</code></a> and executes +<code>form*</code> with the image bound to +<code>name</code>. The image is +guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits. +</blockquote> + + [Special variable] + <a class=none name="default-image">*default-image*</a> + +<blockquote> +Whenever a CL-GD function or macro has an optional or keyword argument called image the default is to use <code>*default-image*</code>. The idea behind this is that you'll never have to provide these arguments as long as you work with one image at a time (which should be the usual case). See the <a href="#example">example</a> at the top of the page. +</blockquote> + + [Macro] + <a class=none name="with-default-image">with-default-image (image) form* => results</a> + +<blockquote> +This is just a convenience macro which will execute <code>form*</code> with <a href="#default-image"><code>*DEFAULT-IMAGE*</code></a> bound to <code>image</code>. +</blockquote> + + + [Macro] + <a class=none name="with-image*">with-image* (width height <tt>&optional</tt> true-color) form* => results</a> + [Macro] + <a class=none name="with-image-from-file*">with-image-from-file* (file-name <tt>&optional</tt> type) form* => results</a> + [Macro] + <a class=none name="with-image-from-gd2-part*">with-image-from-gd2-part* (file-name src-x src-y width height) form* => results</a> + +<blockquote> +These are essentially like their asterisk-less counterparts but bind the image to <a href="#default-image"><code>*DEFAULT-IMAGE*</code></a> instead. +</blockquote> + + + +For the rest of this document, whenever a function expects an image as +one of its arguments you must pass a value which was created +with one of the functions or macros above. An image should be +considered an opaque object which you can pass to CL-GD functions but +should otherwise leave alone. (Internally it is a foreign pointer +wrapped in a <code>CL-GD::IMAGE</code> structure in order to enable +type checking.) + + [Function] + <a class=none name="write-jpeg-to-stream">write-jpeg-to-stream stream <tt>&key</tt> quality image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a JPEG file. If +<code>quality</code> is not specified, the default <a href="http://www.ijg.org/">IJG</a> JPEG +quality value is used. Otherwise, +<code>quality</code> must be an integer in the range 0-100. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-png-to-stream">write-png-to-stream stream <tt>&key</tt> compression-level image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a PNG file. If +<code>compression-level</code> is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of 1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-wbmp-to-stream">write-wbmp-to-stream stream <tt>&key</tt> foreground image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a WBMP (wireless bitmap) file. WBMP file support is black and white +only. The <a href="#colors">color</a> specified by the <code>foreground</code> argument is the +"foreground," and only pixels of this color will be set in the WBMP +file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-gd-to-stream">write-gd-to-stream stream <tt>&key</tt> image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a GD file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-gif-to-stream">write-gif-to-stream stream <tt>&key</tt> image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a GIF file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-gd2-to-stream">write-gd2-to-stream stream <tt>&key</tt> image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a GD2 file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-image-to-stream">write-image-to-stream stream type <tt>&key</tt> <tt>&allow-other-keys</tt> => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code>. The type of the image is determined by <code>type</code> +which must be one of the keywords <code>:JPG</code>, <code>:JPEG</code>, <code>:GIF</code>, <code>:PNG</code>, <code>:WBMP</code>, <code>:GD</code>, or <code>:GD2</code>. The rest of the keyword arguments are handed over to the corresponding <code>WRITE-XXX-TO-STREAM</code> function. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-image-to-file">write-image-to-file file-name <tt>&key</tt> type if-exists <tt>&allow-other-keys</tt> => image</a> + +<blockquote> +Writes image <code>image</code> to the file specified by <code>file-name</code> (which is +either a pathname or a string). The <code>type</code> argument is interpreted as in <a href="#write-image-to-stream"><code>WRITE-IMAGE-TO-STREAM</code></a>. If it is not provided it will be guessed from the <code>PATHNAME-TYPE</code> of +<code>file-name</code>. The <code>if-exists</code> keyword argument is given to <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_open.htm"><code>OPEN</code></a>, +the rest of the keyword arguments are handed over to the corresponding <code>WRITE-XXX-TO-STREAM</code> function. +</blockquote> + + [Function] + <a class=none name="image-width">image-width <tt>&optional</tt> image => width</a> + +<blockquote> +Returns the width of the image <code>image</code>. The result of this function is affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Function] + <a class=none name="image-height">image-height <tt>&optional</tt> image => height</a> + +<blockquote> +Returns the height of the image <code>image</code>. The result of this function is affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Function] + <a class=none name="image-size">image-size <tt>&optional</tt> image => width, height</a> + +<blockquote> +Returns the width and height of the image <code>image</code> as two values. The results of this function are affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + +   <h3><a href="#contents" name="colors" class=none>Colors</a></h3> + +Images in CL-GD are usually palette-based (although true color images +are also supported) and colors have to be <a +href="#allocate-color">allocated</a> before they can be used, i.e. whenever a function expects a color as +one of its arguments you must pass a value which was created +with one of the functions below or with a 'special' color as described in the <a href="#brushes">next section</a>. + +Colors +are determined by specifying values for their red, green, blue, and +optionally alpha <a href="#color-component">components</a>. The first +three have to be integer values in the range 0-255 while the last +one has to be in the range 0-127. For a palette-based image the +first color you allocate will be its background color. Note that +colors are allocated per image, i.e. you can't allocate a color in one +image and then use it to draw something in another image. + +See also the <a href="#brushes">next section</a> for some 'special colors.' + + [Special variable] + <a class=none name="default-color">*default-color*</a> + +<blockquote> +Whenever a CL-GD function or macro has an optional or keyword argument called color the default is to use <code>*default-color*</code>. See <a href="#with-default-color"><code>WITH-DEFAULT-COLOR</code></a> below. +</blockquote> + + [Macro] + <a class=none name="with-default-color">with-default-color (color) form* => results</a> + +<blockquote> +This is just a convenience macro which will execute <code>form*</code> with <a href="#default-color"><code>*DEFAULT-COLOR*</code></a> bound to <code>color</code>. +</blockquote> + + [Function] + <a class=none name="allocate-color">allocate-color red green blue <tt>&key</tt> alpha errorp image => color</a> + +<blockquote> +Finds the first available color index in the image <code>image</code> specified, +sets its RGB values to those requested (255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value in +the case of a true color image. In either case you can then use the +returned value as a color parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If +<code>alpha</code> (not greater than 127) is provided, an RGBA color will always +be allocated. If all <a href="#max-colors"><code>+MAX-COLORS+</code></a> have already been allocated this +function will, depending on the value of <code>errorp</code>, either raise an error +or return <code>NIL</code>. The default is to raise an error. +</blockquote> + + [Function] + <a class=none name="find-color">find-color red green blue <tt>&key</tt> alpha exact hwb resolve image => color</a> + +<blockquote> +Tries to find and/or allocate a color from <code>image</code>'s color +palette. If <code>exact</code> is true, the color will only be returned if it is +already allocated. If <code>exact</code> is false, a color which is 'close' to +the color specified by <code>red</code>, <code>green</code>, and <code>blue</code> (and probably <code>alpha</code>) +might be returned (unless there aren't any colors allocated in the +image yet). If <code>hwb</code> is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If <code>resolve</code> is true a color (probably a new one) will +always be returned, otherwise the result of this function might be +<code>NIL</code>. If <code>alpha</code> (not greater than 127) is provided, an RGBA color (or +<code>NIL</code>) will be returned. +<code>alpha</code>, <code>exact</code>, and <code>hwb</code> are mutually exclusive. <code>resolve</code> can't be used +together with <code>exact</code> or <code>hwb</code>. +</blockquote> + + [Function] + <a class=none name="find-color-from-image">find-color-from-image color source-image <tt>&key</tt> alpha exact hwb resolve image => color</a> + +<blockquote> +Tries to find and/or allocate a color from <code>image</code>'s color +palette that corresponds to <code>color</code> in <code>source-image</code>. +<code>find-color-from-image</code> calls <a href="#find-color"><code>find-color</code></a> +with the color components of <code>color</code>. +Refer to <a href="#find-color"><code>find-color</code></a> for a description of the +keyword arguments. +</blockquote> + + [Function] + <a class=none name="color-component">color-component color component <tt>&key</tt> image => component</a> + +<blockquote> +Returns the specified color component of <code>color</code>. <code>component</code> can be +one of <code>:RED</code>, <code>:GREEN</code>, <code>:BLUE</code>, and <code>:ALPHA</code>. +</blockquote> + + [Function] + <a class=none name="color-components">color-components color <tt>&key</tt> image => components</a> + +<blockquote> +Returns the color components of <code>color</code> as a list. The components are in the +order red, green, blue, alpha. +</blockquote> + +<pre> +* (defun foo () + (<a class=noborder href="#with-image*">with-image*</a> (10 10) + (loop for i below <a class=noborder href="#max-colors">+max-colors+</a> do + ;; allocate enough colors (all gray) to fill the palette + (<a class=noborder href="#allocate-color">allocate-color</a> i i i)) + (format t "Number of colors allocated: ~A~%" (<a class=noborder href="#number-of-colors">number-of-colors</a>)) + (format t "Maximal number of colors: ~A~%" <a class=noborder href="#max-colors">+max-colors+</a>) + (format t "Exact match for red: ~A~%" (<a class=noborder href="#find-color">find-color</a> 255 0 0 :exact t)) + (format t "Red, green, and blue components of 'closest' match for red: ~A~%" + (let ((match (<a class=noborder href="#find-color">find-color</a> 255 0 0))) + (if match + (list (<a class=noborder href="#color-component">color-component</a> :red match) + (<a class=noborder href="#color-component">color-component</a> :green match) + (<a class=noborder href="#color-component">color-component</a> :blue match)))))) + (values)) + +FOO +* (foo) +Number of colors allocated: 256 +Maximal number of colors: 256 +Exact match for red: NIL +Red, green, and blue components of 'closest' match for red: (64 64 64) +</pre> + + [Function] + <a class=none name="deallocate-color">deallocate-color color <tt>&optional</tt> image => color</a> + +<blockquote> +Marks the specified color <code>color</code> as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image <code>image</code>. +</blockquote> + + [Function] + <a class=none name="true-color-p">true-color-p <tt>&optional</tt> image => result</a> + +<blockquote> +Returns true iff <code>image</code> is a true color image. +</blockquote> + + [Function] + <a class=none name="number-of-colors">number-of-colors <tt>&optional</tt> image => result</a> + +<blockquote> +Returns the number of colors allocated in <code>image</code> or NIL if <code>image</code> is a true color image. +</blockquote> + + [Constant] + <a class=none name="max-colors">+max-colors+</a> + +<blockquote> +Maximum number of colors for palette-based images. +</blockquote> + + [Accessor] + <a class=none name="transparent-color">transparent-color <tt>&optional</tt> image => color + (setf (transparent-color <tt>&optional</tt> image) color)</a> + +<blockquote> +Gets and sets the transparent color of <code>image</code>. If <code>color</code> is <code>NIL</code> there is no transparent color. +</blockquote> + + [Accessor] + <a class=none name="alpha-blending-p">alpha-blending-p <tt>&optional</tt> image => blending + (setf (alpha-blending-p <tt>&optional</tt> image) blending)</a> + +<blockquote> +Gets and set whether pixels drawn on <code>image</code> will be copied literally +including alpha channel information (if <code>blending</code> is false) or if +their alpha channel information will determine how much of the +underlying color will shine through (if <code>blending</code> is true). This is +only meaningful for true color images. +</blockquote> + + [Accessor] + <a class=none name="save-alpha-p">save-alpha-p <tt>&optional</tt> image => save + (setf (save-alpha-p <tt>&optional</tt> image) save)</a> + +<blockquote> +Gets and sets whether PNG images will be saved with full alpha channel information. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (200 100)<img vspace=10 hspace=10 border=0 alt="brushed-arc.png" title="brushed-arc.png" src="brushed-arc.png" width=200 height=100 align=right> + (<a class=noborder href="#allocate-color">allocate-color</a> 255 165 0) ; orange background + (<a class=noborder href="#with-image">with-image</a> (brush 6 6) + (let* ((black (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0 :image brush)) ; black background + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0 :image brush)) + (blue (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 255 :image brush))) + (setf (<a class=noborder href="#transparent-color">transparent-color</a> brush) black) ; make background transparent + ;; now set the pixels in the brush + (<a class=noborder href="#set-pixels">set-pixels</a> '(2 2 2 3 3 2 3 3) + :color blue :image brush) + (<a class=noborder href="#set-pixels">set-pixels</a> '(3 2 3 3 1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) + :color red :image brush) + ;; then use it to draw an arc + (<a class=noborder href="#draw-arc">draw-arc</a> 100 50 180 80 180 300 + ;; convert BRUSH to brush + :color (<a class=noborder href="#make-brush">make-brush</a> brush))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "brushed-arc.png" + :compression-level 7 + :if-exists :supersede))) +</pre> + +   <h3><a href="#contents" name="brushes" class=none>Styles, brushes, tiles, anti-aliased lines</a></h3> + +Most <a href="#drawing">drawing</a> and <a href="#strings">string</a> +functions (with <a +href="#draw-freetype-string"><code>DRAW-FREETYPE-STRING</code></a> +being the only exception) will, when expecting a <a +href="#colors">color</a>, also accept other types of arguments. The +full range of allowed types which can be used for +<code>color</code> keyword arguments is listed below: + +<ul> + <li>A style which is either a list or a vector of colors + allocated with one of the functions described above or + <code>NIL</code> for transparent colors. When a style is used as the + color, the colors of the pixels are drawn successively from the + sequence provided. If the corresponding element of the sequence is + <code>NIL</code>, that pixel is not altered. + + <li>A brush as created with <a + href="#make-brush"><code>MAKE-BRUSH</code></a> for drawing lines. A + brush is itself an <a href="#images">image</a> created as described + above. When a brush is used as the color, the brush image is drawn + in place of each pixel of the line drawn. (The brush is usually + larger than one pixel, creating the effect of a wide paintbrush.) + + <li>A tile as created with <a + href="#make-tile"><code>MAKE-TILE</code></a> for filling regions. A + tile is itself an <a href="#images">image</a> created as described + above. When a tile is used as the color, a pixel from the tile image + is selected in such a way as to ensure that the filled area will be + tiled with copies of the tile image. + + <li>A <code>CONS</code> where the <code>CAR</code> is a brush and + the <code>CDR</code> is a list or a vector. This is called a + styled brush. When a styled brush is used as the color, the + brush image is drawn at each pixel of the line, provided that the + corresponding element of the style sequence is true. + (Pixels are drawn successively from the style as the line is drawn, + returning to the beginning when the available pixels in the style + are exhausted.) Note that the semantics described here differ + slightly from the styles described above. + + <li>An anti-aliased color as created with <a + href="#make-anti-aliased"><code>MAKE-ANTI-ALIASED</code></a> for + drawing lines. When an anti-aliased color is used, the line is drawn + with anti-aliasing mechanisms to minimize any "jagged" + appearance. + + <li>A 'normal' color as created with one of the functions from the + <a href="#colors">previous section</a>. + +</ul> + +Note that you can't arbitrarily combine 'color types' and drawing +functions, e.g. you can't set an anti-aliased pixel. However, it +should generally be obvious which types make sense and which don't. +Check the <a +href="http://www.boutell.com/gd/manual2.0.15.html">original GD +documentation</a> for more details. + +In GD itself, if you, say, change a brush after you've 'set' it with +<a +href="http://www.boutell.com/gd/manual2.0.15.html#gdImageSetBrush"><code>gdImageSetBrush</code></a> +but before you actually use it for drawing these changes won't be +visible, i.e. the brush is 'frozen' once it's 'set.' The same applies +to tiles and styles. CL-GD's behaviour differs in this regard, +i.e. brushes, tiles, and styles are 'set' at the very moment they're +used. This introduces a little bit of overhead but feels more 'Lisp-y' +and intuitive to me. + + [Function] + <a class=none name="make-brush">make-brush image => brush</a> + +<blockquote> + +Creates a <a href="#brushes">brush</a> from the <a +href="#images">image</a> <code>image</code>. Note that the new +brush is still 'linked' to <code>image</code>, i.e. changes you +make to <code>image</code> will also be visible in the +brush - the brush is just a kind of 'tagged' image. + +</blockquote> + + [Function] + <a class=none name="make-tile">make-tile image => tile</a> + +<blockquote> + +Creates a <a href="#brushes">tile</a> from the <a +href="#images">image</a> <code>image</code>. Note that the new +tile is still 'linked' to <code>image</code>, i.e. changes you +make to <code>image</code> will also be visible in the +tile - the tile is just a kind of 'tagged' image. + +</blockquote> + + [Function] + <a class=none name="make-anti-aliased">make-anti-aliased color <tt>&optional</tt>do-not-blend => color'</a> + +<blockquote> + +Creates an <a href="#brushes">anti-aliased color</a> from the +<a href="#colors">color</a> +<code>color</code>. <code>do-not-blend</code> (if provided) is the +color anti-aliased lines stand out against clearly. + +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (150 50)<img vspace=10 hspace=10 border=0 alt="anti-aliased-lines.png" title="anti-aliased-lines.png" src="anti-aliased-lines.png" width=150 height=50 align=right> + (let ((orange (<a class=noborder href="#allocate-color">allocate-color</a> 255 165 0)) ; orange background + (white (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0))) + ;; white background rectangle in the middle third + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 50 0 99 49 + :filled t + :color white) + (<a class=noborder href="#with-thickness">with-thickness</a> (2) + ;; just a red line + (<a class=noborder href="#draw-line">draw-line</a> 5 10 145 10 :color red) + ;; anti-aliased red line + (<a class=noborder href="#draw-line">draw-line</a> 5 25 145 25 :color (<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> red)) + ;; anti-aliased red line which should stand out against + ;; orange background + (<a class=noborder href="#draw-line">draw-line</a> 5 40 145 40 :color (<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> red orange)))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "anti-aliased-lines.png" + :compression-level 3 + :if-exists :supersede)) +</pre> + +   <h3><a href="#contents" name="transformations" class=none>Transformations</a></h3> + +Usually, CL-GD coordinates and dimensions (width and height) have to be integers. The origin <code>(0,0)</code> of an <a href="#images">image</a> is its upper left corner and all other points like <code>(X,Y)</code> have positive <code>X</code> and <code>Y</code> values. Angles are also provided as integers (in the range 0-360) meaning degrees. A transformation provides a way to change this. + + [Macro] + <a class=none name="with-transformation">with-transformation (<tt>&key</tt> x1 x2 width y1 y2 height reverse-x reverse-y radians image) form* => results</a> + +<blockquote> +Executes <code>form*</code> such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of <code>image</code> will start at <code>x1</code> and end at <code>x2</code> and +have length <code>width</code>. The new y-axis of <code>image</code> will start at <code>y1</code> and end at +<code>y2</code> and have length <code>height</code>. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +<code>reverse-x</code> is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to <code>reverse-y</code>, of course. If <code>radians</code> is true angles inside of +the macro's body will be assumed to be provided in radians, otherwise in degrees. The previous transformation (if any) will be restored before this macro exits. + +<code>with-transformation</code> macros can be nested but they always transform the original coordinates of the image, i.e. you shouldn't expect that, say, two succesive applications of <code>reverse-x</code> will neutralize each other. There's a little bit of overhead involved with this macro, so it is recommended to wrap it around everything you do with an image instead of calling it repeatedly. Note that transformations are always bound to one particular image. +</blockquote> + + [Macro] + <a class=none name="without-transformations">without-transformations form* => results</a> + +<blockquote> +Executes <code>form*</code> without any transformations applied. +</blockquote> + +   <h3><a href="#contents" name="drawing" class=none>Drawing and filling</a></h3> + +This section (and the next one about <a href="#strings">strings</a>) finally describes how you can actually change the visual appearance of an <a href="#images">image</a>. You can set single pixels, draw lines or geometric figures, and fill regions. Note that the current <a href="#transformations">transformation</a> (if any) applies to the input and output of these functions. + + [Function] + <a class=none name="get-pixel">get-pixel x y <tt>&key</tt> image => color</a> + +<blockquote> +Returns the <a href="#colors">color</a> of the pixel specified by <code>x</code> and <code>y</code>. +</blockquote> + + [Function] + <a class=none name="set-pixel">set-pixel x y <tt>&key</tt> color image => x, y</a> + +<blockquote> +Sets the pixel specified by <code>x</code> and <code>y</code> to the <a href="#colors">color</a> specified by <code>color</code>. +</blockquote> + + [Generic function] + <a class=none name="set-pixels">set-pixels points <tt>&key</tt> color image => points</a> + +<blockquote> +Sets the pixels specified by <code>points</code> which can be a list <code>(X1 Y1 X2 Y2 ...)</code> or a vector <code>#(X1 Y1 X2 Y2 ...)</code> to the <a href="#colors">color</a> specified by <code>color</code>. +</blockquote> + + [Function] + <a class=none name="draw-line">draw-line x1 y1 x2 y2 <tt>&key</tt> color image => x1, y1, x2, y2</a> + +<blockquote> +Draws a line with <a href="#colors">color</a> <code>color</code> from point <code>(x1,y1)</code> to point <code>(x2,y2)</code>. +</blockquote> + + [Function] + <a class=none name="draw-rectangle">draw-rectangle rectangle <tt>&key</tt> filled color image => rectangle</a> + +<blockquote> +Draws a rectangle with upper left corner <code>(X1,Y1)</code> and lower right corner <code>(X2,Y2)</code> where <code>rectangle</code> is the list <code>(X1 Y2 X2 Y2)</code>. If <code>filled</code> is true the rectangle will be filled with <code>color</code>, otherwise it will be outlined. +</blockquote> + + [Function] + <a class=none name="draw-rectangle*">draw-rectangle* x1 y1 x2 y2 <tt>&key</tt> filled color image => x1, y1, x2, y2</a> + +<blockquote> +Draws a rectangle with upper left corner <code>(x1,y1)</code> and lower right corner <code>(x2,y2)</code>. If <code>filled</code> is true the rectangle will be filled with <code>color</code>, otherwise it will be outlined. +</blockquote> + + [Generic function] + <a class=none name="draw-polygon">draw-polygon vertices <tt>&key</tt> filled start end color image => vertices</a> + +<blockquote> +Draws a polygon with the vertices (at least three) +specified as a list <code>(X1 Y1 X2 Y2 ...)</code> or as a vector <code>#\(X1 Y1 X2 Y2 ...)</code>. +If <code>filled</code> is true the polygon will be filled with the <a href="#colors">color</a> <code>color</code>, +otherwise it will be outlined. If <code>start</code> and/or <code>end</code> are specified then +only the corresponding part of <code>vertices</code> is used as input. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (100 100)<img vspace=10 hspace=10 border=0 alt="triangle.png" title="triangle.png" src="triangle.png" width=100 height=100 align=right> + (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255) ; white background + (let ((red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0)) + (yellow (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 0)) + (orange (<a class=noborder href="#allocate-color">allocate-color</a> 255 165 0))) + ;; thin black border + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 0 0 99 99 + :color (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0)) + ;; line thickness is five pixels + (<a class=noborder href="#with-thickness">with-thickness</a> (5) + ;; triangle + (<a class=noborder href="#draw-polygon">draw-polygon</a> (list 10 10 90 50 50 90) + ;; styled color + :color (list red red red + yellow yellow yellow + nil nil nil + orange orange orange)) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "triangle.png" + :compression-level 8 + :if-exists :supersede)))) +</pre> + + [Function] + <a class=none name="draw-filled-circle">draw-filled-circle center-x center-y radius <tt>&key</tt> color image => center-x center-y radius</a> + +<blockquote> +Draws a filled circle with center <code>(center-x,center-y)</code> and radius <code>radius</code>. +</blockquote> + + [Function] + <a class=none name="draw-filled-ellipse">draw-filled-ellipse center-x center-y width height <tt>&key</tt> color image => center-x center-y width height</a> + +<blockquote> +Draws a filled ellipse with center <code>(center-x,center-y)</code>, width <code>width</code>, and height <code>height</code>. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (250 150) + (<a class=noborder href="#with-image-from-file">with-image-from-file</a> (zappa "smallzappa.png")<img vspace=10 hspace=0 border=0 alt="zappa-ellipse.png" title="zappa-ellipse.png" src="zappa-ellipse.png" width=250 height=150 align=right> + (setf (<a class=noborder href="#transparent-color">transparent-color</a>) (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (<a class=noborder href="#draw-filled-ellipse">draw-filled-ellipse</a> 125 75 250 150 + :color (<a class=noborder href="#make-tile">make-tile</a> zappa))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "zappa-ellipse.png" + :if-exists :supersede)) +</pre> + + [Function] + <a class=none name="draw-arc">draw-arc center-x center-y width height start end <tt>&key</tt> straight-line center-connect filled color image => center-x, center-y, width, height, start, end</a> + +<blockquote> +Draws a partial ellipse centered at <code>(center-x,center-y)</code> with +width <code>width</code> and height <code>height</code>. The arc begins at angle <code>start</code> and ends +at angle <code>end</code>. If <code>straight-line</code> is true the start and end points are +just connected with a straight line. If <code>center-connect</code> is true, they +are connected to the center (which is useful to create 'pie +slices' - see <a href="#example">example</a> at the top of the page.). If <code>filled</code> is true the arc will be filled with the <a href="#colors">color</a> <code>color</code>, otherwise it will be outlined. +</blockquote> + + [Function] + <a class=none name="fill-image">fill-image x y <tt>&key</tt> border color image => x, y</a> + +<blockquote> +Floods a portion of the <a href="#images">image</a> <code>image</code> with the <a href="#colors">color</a> <code>color</code> beginning +at point <code>(x,y)</code> and extending into the surrounding region. If <code>border</code> +is true it must be a <a href="#colors">color</a> and the filling will stop at the specified +border color. (You can't use <a href="#brushes">'special colors'</a> for the border color.) Otherwise only points with the same color as the +starting point will be colored. If <code>color</code> is a <a href="#brushes">tile</a> the tile must not have a <a href="#transparent-color">transparent</a> color. +</blockquote> + + [Accessor] + <a class=none name="clipping-rectangle">clipping-rectangle <tt>&optional</tt> image => rectangle + (setf (clipping-rectangle <tt>&optional</tt> image) rectangle)</a> + +<blockquote> +Gets and sets the clipping rectangle of <code>image</code> where <code>rectangle</code> should be a +list <code>(X1 Y1 X2 Y2)</code> describing the upper left and lower right corner of the rectangle. Once a clipping rectangle has been set, all future drawing operations on <code>image</code> will remain within the specified clipping area, until a new clipping rectangle is established. For instance, if a clipping rectangle <code>(25 25 75 75)</code> has been set within a 100x100 image, a diagonal line from <code>(0,0)</code> to <code>(99,99)</code> will appear only between <code>(25,25)</code> and <code>(75,75)</code>. See also <a href="#clipping-rectangle*"><code>CLIPPING-RECTANGLE*</code></a> and <a href="#set-clipping-rectangle*"><code>SET-CLIPPING-RECTANGLE*</code></a>. +</blockquote> + + [Function] + <a class=none name="clipping-rectangle*">clipping-rectangle* <tt>&optional</tt> image => x1, y1, x2, y2</a> + +<blockquote> +Returns the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> as four values. +</blockquote> + + [Function] + <a class=none name="set-clipping-rectangle*">set-clipping-rectangle* x1 y1 x2 y2 <tt>&optional</tt> image => x1, y1, x2, y2</a> + +<blockquote> +Sets the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> as if set with <code>(SETF (<a href="#clipping-rectangle"><code>CLIPPING-RECTANGLE</code></a> IMAGE) (LIST X1 Y1 X2 Y2))</code>. +</blockquote> + + [Macro] + <a class=none name="with-clipping-rectangle">with-clipping-rectangle (rectangle <tt>&key</tt> image) form* => results</a> + +<blockquote> +Executes <code>form*</code> with the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> set to <code>rectangle</code> +which should be a list as in <a href="#clipping-rectangle"><code>CLIPPING-RECTANGLE</code></a>. The previous clipping rectangle +is guaranteed to be restored before the macro exits. +</blockquote> + + [Macro] + <a class=none name="with-clipping-rectangle*">with-clipping-rectangle* (x1 y1 x2 y2 <tt>&key</tt> image) form* => results</a> + +<blockquote> +Executes <code>form*</code> with the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> set as if set with <code>(SETF (<a href="#clipping-rectangle"><code>CLIPPING-RECTANGLE</code></a> IMAGE) (LIST X1 Y1 X2 Y2))</code>. The previous clipping rectangle +is guaranteed to be restored before the macro exits. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (150 150)<img vspace=10 hspace=10 border=0 alt="clipped-tangent.png" title="clipped-tangent.png" src="clipped-tangent.png" width=150 height=150 align=right> + (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255) ; white background + ;; transform such that x axis ranges from (- PI) to PI and y + ;; axis ranges from -3 to 3 + (<a class=noborder href="#with-transformation">with-transformation</a> (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) + (let ((black (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0)) + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0)) + (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) + (<a class=noborder href="#with-default-color">with-default-color</a> (black) + ;; draw axes + (<a class=noborder href="#draw-line">draw-line</a> 0 -3 0 3 :color black) + (<a class=noborder href="#draw-line">draw-line</a> (- pi) 0 pi 0)) + ;; show clipping rectangle (styled) + (<a class=noborder href="#draw-rectangle">draw-rectangle</a> rectangle :color (list black black black nil black nil)) + (<a class=noborder href="#with-clipping-rectangle">with-clipping-rectangle</a> (rectangle) + ;; draw tangent function + (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do + (<a class=noborder href="#set-pixel">set-pixel</a> x (tan x) :color red))))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "clipped-tangent.png" + :if-exists :supersede)) +</pre> + + [Accessor] + <a class=none name="current-thickness">current-thickness <tt>&optional</tt> image => thickness + (setf (current-thickness <tt>&optional</tt> image) thickness)</a> + +<blockquote> +Get and sets the current thickness of <code>image</code> in pixels. This determines the width of lines drawn with the <a href="#drawing">drawing</a> functions. <code>thickness</code> has to be an integer. See also <a href="#with-thickness"><code>WITH-THICKNESS</code></a>. +</blockquote> + + [Macro] + <a class=none name="with-thickness">with-thickness (thickness <tt>&key</tt> image) form* => results</a> + +<blockquote> +Executes <code>form*</code> with the <a href="#current-thickness">current thickness</a> of <code>image</code> set to <code>thickness</code>. The image's previous thickness is guaranteed to be restored +before the macro exits. +</blockquote> + +   <h3><a href="#contents" name="strings" class=none>Characters and strings</a></h3> + +CL-GD (actually GD) comes with five included fonts which can be accessed with the keywords <code>:TINY</code>, <code>:SMALL</code>, <code>:MEDIUM</code>, <code>:MEDIUM-BOLD</code> (a synonym for <code>:MEDIUM</code>), <code>:LARGE</code>, and <code>:GIANT</code> and used with <a href="#draw-string"><code>DRAW-STRING</code></a> and <a href="#draw-character"><code>DRAW-CHARACTER</code></a>. Using these fonts will make your application portable to all platforms supported by CL-GD (and thus GD). You can also invoke the <a href="http://www.freetype.org/">FreeType library</a> to draw (anti-aliased) strings with arbitrary TrueType fonts, sizes, and angles. This is, however, subject to the availability and location of the corresponding fonts on your target platform. + + [Special variable] + <a class=none name="default-font">*default-font*</a> + +<blockquote> +Whenever a CL-GD string or character function has an optional or keyword argument called font or font-name the default is to use <code>*default-font*</code>. See <a href="#with-default-font"><code>WITH-DEFAULT-FONT</code></a> below. +</blockquote> + + [Macro] + <a class=none name="with-default-font">with-default-font (font) form* => results</a> + +<blockquote> +This is just a convenience macro which will execute <code>form*</code> with <a href="#default-font"><code>*DEFAULT-FONT*</code></a> bound to <code>font</code>. But +note that the fonts used for <a href="#draw-string"><code>DRAW-STRING</code></a>/<a href="#draw-character"><code>DRAW-CHARACTER</code></a> and <a href="#draw-freetype-string"><code>DRAW-FREETYPE-STRING</code></a> are incompatible +</blockquote> + + [Function] + <a class=none name="draw-character">draw-character x y char <tt>&key</tt> up font color image => char</a> + +<blockquote> +Draws the character <code>char</code> from font <code>font</code> in color <code>color</code> at position <code>(x,y)</code>. If +<code>up</code> is true the character will be drawn from bottom to top (rotated 90 degrees). <code>font</code> must be one of the keywords listed <a href="#strings">above</a>. +</blockquote> + + [Function] + <a class=none name="draw-string">draw-string x y string <tt>&key</tt> up font color image => string</a> + +<blockquote> +Draws the string <code>string</code> in color <code>color</code> at position <code>(y,y)</code>. If +<code>up</code> is true the string will be drawn from bottom to top (rotated 90 degrees). <code>font</code> must be one of the keywords listed <a href="#strings">above</a>. +</blockquote> + + [Function] + <a class=none name="draw-freetype-string">draw-freetype-string x y string <tt>&key</tt> anti-aliased point-size angle convert-chars line-spacing font-name do-not-draw color image => bounding-rectangle</a> + +<blockquote> +Draws the string <code>string</code> in <a href="#colors">color</a> <code>color</code> at position <code>(x,y)</code> using the +<a href="http://www.freetype.org/">FreeType</a> library. <code>font-name</code> is the full path (a pathname or a string) +to a TrueType font file, or a font face name if the <code>GDFONTPATH</code> +environment variable or FreeType's <code>DEFAULT_FONTPATH</code> variable have been +set intelligently. The string may be arbitrarily scaled (<code>point-size</code>) +and rotated (<code>angle</code> in radians). The direction of rotation is +counter-clockwise, with 0 radians (0 degrees) at 3 o'clock and <code>(/ PI 2)</code> radians (90 degrees) at 12 o'clock. Note that the <code>angle</code> argument is +purposefully not affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. If <code>anti-aliased</code> if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +<code>line-spacing</code>, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like "&#192;". If <code>convert-chars</code> is true (which is the default) +characters of <code>string</code> with <code>CHAR-CODE</code> greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's <code>CHAR-CODE</code> +function returns ISO/IEC 10646 (Unicode) character codes. + +The return value is an array containing 8 elements representing +the 4 corner coordinates (lower left, lower right, upper right, upper left) of the bounding rectangle around the +string that was drawn. The points are relative to the text regardless +of the angle, so "upper left" means in the top left-hand +corner seeing the text horizontally. Set <code>do-not-draw</code> +to true to get the bounding +rectangle without rendering. This is a relatively cheap operation if +followed by a rendering of the same string, because of the caching of +the partial rendering during bounding rectangle calculation. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (200 200)<img vspace=0 hspace=0 border=0 alt="strings.png" title="strings.png" src="strings.png" width=200 height=200 align=right> + ;; set background (white) and make it transparent + (setf (<a class=noborder href="#transparent-color">transparent-color</a>) + (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (loop for angle from 0 to (* 2 pi) by (/ pi 6) + for blue downfrom 255 by 20 do + (<a class=noborder href="#draw-freetype-string">draw-freetype-string</a> 100 100 "Common Lisp" + :font-name "/usr/X11R6/lib/X11/fonts/truetype/georgia.ttf" + :angle angle + ;; note that ALLOCATE-COLOR won't work + ;; here because the anti-aliasing uses + ;; up too much colors + :color (<a class=noborder href="#find-color">find-color</a> 0 0 blue + :resolve t))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "strings.png" + :if-exists :supersede)) +</pre> + +   <h3><a href="#contents" class=none name="misc">Miscellaneous</a></h3> + +Things that didn't seem to fit into one of the other categories... + + [Macro] + <a class=none name="do-rows">do-rows (y-var <tt>&optional</tt> image) declaration* form* => results</a> + +<blockquote> +This macro loops through all rows (from top to bottom) in turn and +executes <code>form*</code> for each row with +<code>y-var</code> bound to the vertical index of the current row +(starting with <code>0</code>). It is not affected by <a +href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Local macro] + <a class=none name="do-pixels-in-row">do-pixels-in-row (x-var) declaration* form* => results</a> + +<blockquote> +This macro is only available within the body of a <a +href="#do-rows"><code>DO-ROWS</code></a> form. +It loops through all pixels (from left to right) in turn and +executes <code>form*</code> for each pixel with +<code>x-var</code> bound to the horizontal index of the current pixel +(starting with <code>0</code>). It is not affected by <a +href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Macro] + <a class=none name="do-pixels">do-pixels (<tt>&optional</tt> image) declaration* form* => results</a> + +<blockquote> +This is a shortcut for the previous two macros. It loops through all pixels and executes <code>form*</code> for each pixel. Obviously it only makes sense when used together with <a +href="#raw-pixel"><code>RAW-PIXEL</code></a>. +</blockquote> + + [Accessor] + <a class=none name="raw-pixel">raw-pixel => pixel + (setf (raw-pixel) pixel)</a> + +<blockquote> +This accessor is only available within the body of a <a +href="#do-pixels-in-row"><code>DO-PIXELS-IN-ROW</code></a> form (and +thus also within <a href="#do-pixels"><code>DO-PIXELS</code></a> +forms). It provides access to the "raw" pixel the loop is +currently at, i.e. for true color images you access an element of the +<code>im->tpixels</code> array, for palette-based images it's +<code>im->pixels</code>. Read the <a +href="http://www.boutell.com/gd/manual2.0.15.html">original GD +documentation</a> for details. Make sure you know what you're doing if +you change these values... +</blockquote> + +<pre> +* (<a class=noborder href="#with-image*">with-image*</a> (3 3 t) ; true-color image with 3x3 pixels + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 0 0 2 2 :color (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0)) ; black background + (<a class=noborder href="#draw-line">draw-line</a> 0 0 2 2 :color (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) ; white line + (<a class=noborder href="#do-pixels">do-pixels</a> () + ;; loop through all pixels and change those which arent't black + (unless (zerop (<a class=noborder href="#raw-pixel">raw-pixel</a>)) + (decf (<a class=noborder href="#raw-pixel">raw-pixel</a>) #xff))) + (<a class=noborder href="#do-rows">do-rows</a> (y) + ;; loop through all rows + (format t "Starting with row ~A~%" y) + (<a class=noborder href="#do-pixels-in-row">do-pixels-in-row</a> (x) + ;; loop through all pixels in row + (format t " Pixel <~A,~A> has value ~X~%" x y (<a class=noborder href="#raw-pixel">raw-pixel</a>))) + (format t "Done with row ~A~%" y))) +Starting with row 0 + Pixel <0,0> has value FFFF00 ; the line is yellow now + Pixel <1,0> has value 0 + Pixel <2,0> has value 0 +Done with row 0 +Starting with row 1 + Pixel <0,1> has value 0 + Pixel <1,1> has value FFFF00 + Pixel <2,1> has value 0 +Done with row 1 +Starting with row 2 + Pixel <0,2> has value 0 + Pixel <1,2> has value 0 + Pixel <2,2> has value FFFF00 +Done with row 2 +NIL +</pre> + + [Accessor] + <a class=none name="interlacedp">interlacedp <tt>&optional</tt> image => interlaced + (setf (interlacedp <tt>&optional</tt> image) interlaced)</a> + +<blockquote> +Gets or sets whether <code>image</code> will be stored in an interlaced fashion. +</blockquote> + + [Function] + <a class=none name="differentp">differentp image1 image2 => different</a> + +<blockquote> +Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images. +</blockquote> + + [Function] + <a class=none name="copy-image">copy-image source destination source-x source-y dest-x dest-y width height <tt>&key</tt> resample rotate angle resize dest-width dest-height merge merge-gray => destination</a> + +<blockquote> +Copies (a part of) the <a href="#images">image</a> <code>source</code> into the image <code>destination</code>. Copies the +rectangle with the upper left corner <code>(source-x,source-y)</code> and size +<code>width</code> <tt>x</tt> <code>height</code> to the rectangle with the upper left corner <code>(dest-x,dest-y)</code>. + +If <code>resample</code> is true pixel colors will be +smoothly interpolated. If <code>resize</code> is true +the copied rectangle will be strechted or shrunk so that its size is +<code>dest-width</code> <tt>x</tt> +<code>dest-height</code>. If <code>rotate</code> is true +the image will be rotated by <code>angle</code>. In this +particular case <code>dest-x</code> and +<code>dest-y</code> specify the center of the copied +image rather than its upper left corner! If <code>merge</code> +is true then it has to be an integer in the range 0-100 and the +two images will be 'merged' by the amount specified. If +<code>merge</code> is 100 then the source image will simply be +copied. If instead <code>merge-gray</code> is true the hue of +the source image is preserved by converting the destination area to +gray pixels before merging. + +The keyword arguments <code>resample</code>, <code>rotate</code>, <code>resize</code>, <code>merge</code>, and <code>merge-gray</code> +are mutually exclusive (with the exception of <code>resample</code> and +<code>resize</code>). <code>angle</code> is assumed to be specified in degrees if it's an +integer, and in radians otherwise. This function is not affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Function] + <a class=none name="copy-palette">copy-palette source destination => destination</a> + +<blockquote> +Copies the palette of the <a href="#images">image</a> <code>source</code> to the image <code>destination</code> attempting to +match the colors in the target image to the colors in the source palette. +</blockquote> + + [Function] + <a class=none name="true-color-to-palette">true-color-to-palette <tt>&key</tt> dither colors-wanted image => image</a> + +<blockquote> +Converts the true color image <code>image</code> to a palette-based image using +a high-quality two-pass quantization routine. If <code>dither</code> is true, the +image will be dithered to approximate colors better, at the expense of +some obvious "speckling." <code>colors-wanted</code> can be any positive integer +up to 256 (which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> ((+ 256 384) 384 t) + (let ((white (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0)) + (green (<a class=noborder href="#allocate-color">allocate-color</a> 0 255 0)) + (blue (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 255)) + (vertices (list 64 0 0 128 128 128)) + (image-width (<a class=noborder href="#image-width">image-width</a>)) + (image-height (<a class=noborder href="#image-height">image-height</a>))) + (setf (<a class=noborder href="#transparent-color">transparent-color</a>) white) + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 0 0 image-width image-height :color white) + ;; "demoin.png" is part of the GD distribution + (<a class=noborder href="#with-image-from-file">with-image-from-file</a> (in-file "demoin.png") + (<a class=noborder href="#copy-image">copy-image</a> in-file *default-image* + 0 0 32 32 192 192 + :resize t + :dest-width 255 + :dest-height 255 + :resample t) + (multiple-value-bind (in-width in-height) + (<a class=noborder href="#image-size">image-size</a> in-file) + (loop for a below 360 by 45 do + (<a class=noborder href="#copy-image">copy-image</a> in-file *default-image* + 0 0 + (+ 256 192 (* 128 (cos (* a .0174532925)))) + (- 192 (* 128 (sin (* a .0174532925)))) + in-width in-height + :rotate t + :angle a)) + (<a class=noborder href="#with-default-color">with-default-color</a> (green) + (<a class=noborder href="#with-thickness">with-thickness</a> (4) + (<a class=noborder href="#draw-line">draw-line</a> 16 16 240 16) + (<a class=noborder href="#draw-line">draw-line</a> 240 16 240 240) + (<a class=noborder href="#draw-line">draw-line</a> 240 240 16 240) + (<a class=noborder href="#draw-line">draw-line</a> 16 240 16 16)) + (<a class=noborder href="#draw-polygon">draw-polygon</a> vertices :filled t)) + (dotimes (i 3) + (incf (nth (* 2 i) vertices) 128)) + (<a class=noborder href="#draw-polygon">draw-polygon</a> vertices + :color (<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> green) + :filled t) + (<a class=noborder href="#with-default-color">with-default-color</a> (blue) + (<a class=noborder href="#draw-arc">draw-arc</a> 128 128 60 20 0 720) + (<a class=noborder href="#draw-arc">draw-arc</a> 128 128 40 40 90 270) + (<a class=noborder href="#fill-image">fill-image</a> 8 8)) + (<a class=noborder href="#with-image">with-image</a> (brush 16 16 t) + (<a class=noborder href="#copy-image">copy-image</a> in-file brush + 0 0 0 0 + in-width in-height + :resize t + :dest-width (<a class=noborder href="#image-width">image-width</a> brush) + :dest-height (<a class=noborder href="#image-height">image-height</a> brush)) + (<a class=noborder href="#draw-line">draw-line</a> 0 255 255 0 + :color (cons (<a class=noborder href="#make-brush">make-brush</a> brush) + (list nil nil nil nil nil nil nil t)))))) + (<a class=noborder href="#with-default-color">with-default-color</a> (red) + (<a class=noborder href="#draw-string">draw-string</a> 32 32 "hi" :font :giant) + (<a class=noborder href="#draw-string">draw-string</a> 64 64 "hi" :font :small)) + (<a class=noborder href="#with-clipping-rectangle*">with-clipping-rectangle*</a> (0 (- image-height 100) 100 image-height) + (<a class=noborder href="#with-default-color">with-default-color</a> ((<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> white)) + (dotimes (i 100) + (<a class=noborder href="#draw-line">draw-line</a> (random image-width) + (random image-height) + (random image-width) + (random image-height)))))) + (setf (<a class=noborder href="#interlacedp">interlacedp</a>) t) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "demoout.png" + :if-exists :supersede) + (<a class=noborder href="#true-color-to-palette">true-color-to-palette</a>) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "demooutp.png" + :if-exists :supersede)) +</pre> + +This last example is the demo which comes with GD. The equivalent C code is <a href="gddemo.c">here</a>. + + +<img border=0 alt="demooutp.png" title="demooutp.png" src="demooutp.png" width=640 height=384> + +   <h3><a href="#contents" class=none name="ack">Acknowledgements</a></h3> + +Thanks to Thomas Boutell for <a +href="http://www.boutell.com/gd/">GD</a> and thanks to Kevin Rosenberg +for <a href="http://uffi.b9.com/">UFFI</a> without which CL-GD would +not have been possible. Kevin was also extremely helpful when I needed +functionality which wasn't yet part of UFFI. Thanks to <a href="http://huebner.org/">Hans +Hübner</a> for the GIF patches. Thanks to <a href='http://bl0rg.net/'>Manuel Odendahl</a> for lots of useful patches. +Thanks to Luis Oliveira for CLISP/CFFI support and to Bryan O'Connor for OpenMCL support. + +$Header: /usr/local/cvsrep/gd/doc/index.html,v 1.75 2007/07/29 16:37:15 edi Exp $ +<a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html> Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/smallzappa.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/strings.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/triangle.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/drawing.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/drawing.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,354 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/drawing.lisp,v 1.28 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun get-pixel (x y &key (image *default-image*)) + "Gets the color associated with point \(X,Y)." + (check-type image image) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-get-pixel (img image) x y))) + +(defun set-pixel (x y &key (color *default-color*) (image *default-image*)) + "Draws a pixel with color COLOR at point \(X,Y)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel (img image) x y color))) + (values x y)) + +(defgeneric set-pixels (points &key color image) + (:documentation "Draws a list \(X1 Y1 X2 Y2 ...) or vector #\(X1 Y1 +X2 Y2 ...) of pixels.")) + +(defmethod set-pixels ((points list) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (unless (evenp (length points)) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for (x y) on points by #'cddr do + (check-type x integer) + (check-type y integer) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel img x y color)) + finally (return image))) + +(defmethod set-pixels ((points vector) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (let ((length (length points))) + (unless (evenp length) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for i below length by 2 do + (check-type (aref points i) integer) + (check-type (aref points (1+ i)) integer) + (with-transformed-alternative + (((aref points i) x-transformer) + ((aref points (1+ i)) y-transformer)) + (gd-image-set-pixel img + (aref points i) + (aref points (1+ i)) + color)) + finally (return image)))) + +(defun draw-line (x1 y1 x2 y2 &key (color *default-color*) (image *default-image*)) + "Draws a line with color COLOR from point \(X1,Y1) to point \(X2,Y2)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-line (img image) x1 y1 x2 y2 color))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle* (x1 y1 x2 y2 &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2). If FILLED is true the rectangle will be filled with +COLOR, otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (if filled + (gd-image-filled-rectangle (img image) x1 y1 x2 y2 color) + (gd-image-rectangle (img image) x1 y1 x2 y2 color)))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle (rectangle &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2) where RECTANGLE is the list \(X1 Y1 X2 Y2). If FILLED +is true the rectangle will be filled with COLOR, otherwise it will be +outlined." + (draw-rectangle* (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle) + :filled filled + :color color + :image image) + rectangle) + +(defgeneric draw-polygon (vertices &key filled start end color image) + (:documentation "Draws a polygon with the VERTICES \(at least three) +specified as a list \(x1 y1 x2 y2 ...) or as a vector #\(x1 y1 x2 y2 +...). If FILLED is true the polygon will be filled with COLOR, +otherwise it will be outlined. If START and/or END are specified then +only the corresponding part of VERTICES is used as input.")) + +(defmethod draw-polygon ((vertices vector) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((aref vertices i) x-transformer) + ((aref vertices (1+ i)) y-transformer)) + (loop for i from start below end by 2 + for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (aref vertices i) + (get-slot-value point-ptr 'gd-point 'y) + (aref vertices (1+ i)))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defmethod draw-polygon ((vertices list) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((first x/y) x-transformer) + ((second x/y) y-transformer)) + (loop for i below (- end start) by 2 + ;; we don't use LOOP's destructuring capabilities here + ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE + ;; macro which would get confused + for x/y on (nthcdr start vertices) by #'cddr + for point-ptr = (deref-array arr '(:array gd-point) (/ i 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (first x/y) + (get-slot-value point-ptr 'gd-point 'y) + (second x/y))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defun draw-filled-ellipse (center-x center-y width height &key (color *default-color*) (image *default-image*)) + "Draws a filled ellipse centered at \(CENTER-X, CENTER-Y) with width +WIDTH and height HEIGHT." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer)) + (gd-image-filled-ellipse (img image) center-x center-y width height color))) + (values center-x center-y width height)) + +(defun draw-filled-circle (center-x center-y radius &key (color *default-color*) (image *default-image*)) + "Draws a filled circle centered at \(CENTER-X, CENTER-Y) with radius +RADIUS." + (draw-filled-ellipse center-x center-y (* 2 radius) (* 2 radius) + :color color :image image) + (values center-x center-y radius)) + +(defun draw-arc (center-x center-y width height start end &key straight-line center-connect filled (color *default-color*) (image *default-image*)) + "Draws a partial ellipse centered at \(CENTER-X, CENTER-Y) with +width WIDTH and height HEIGHT. The arc begins at angle START and ends +at angle END. If STRAIGHT-LINE is true the start and end points are +just connected with a straight line. If CENTER-CONNECT is true, they +are connected to the center \(which is useful to create 'pie +slices'). If FILLED is true the arc will be filled with COLOR, +otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer) + (start angle-transformer) + (end angle-transformer)) + (cond ((not (or straight-line filled center-connect)) + (gd-image-arc (img image) center-x center-y width height start end color)) + (t + (gd-image-filled-arc (img image) center-x center-y width height start end color + (logior (if straight-line +gd-chord+ 0) + (if filled 0 +gd-no-fill+) + (if center-connect +gd-edged+ 0))))))) + (values center-x center-y width height start end)) + +(defun fill-image (x y &key border (color *default-color*) (image *default-image*)) + "Floods a portion of the image IMAGE with the color COLOR beginning +at point \(X, Y) and extending into the surrounding region. If BORDER +is true it must be a color and the filling will stop at the specified +border color. Otherwise only points with the same color as the +starting point will be colored." + (check-type border (or null integer)) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if border + (gd-image-fill-to-border (img image) x y border color) + (gd-image-fill (img image) x y color)))) + (values x y)) + +(defun clipping-rectangle (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as a list of four +elements." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (list (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun (setf clipping-rectangle) (rectangle &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE where rectangle should be a +list \(X1 Y1 X2 Y2)." + (check-type image image) + (with-transformed-alternative + (((first rectangle) x-transformer) + ((second rectangle) y-transformer) + ((third rectangle) x-transformer) + ((fourth rectangle) y-transformer)) + (gd-image-set-clip (img image) + (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle))) + rectangle) + +(defun clipping-rectangle* (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as four values." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (values (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun set-clipping-rectangle* (x1 y1 x2 y2 &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE to be the rectangle with upper +left corner \(X1, Y1) and lower right corner \(X2, Y2)." + (check-type image image) + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-set-clip (img image) x1 y1 x2 y2)) + (values x1 y1 x2 y2)) + +(defmacro with-clipping-rectangle ((rectangle &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to RECTANGLE +which should be a list \(X1 Y1 X2 Y2). The previous clipping rectangle +is guaranteed to be restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (rectangle image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (setf (clipping-rectangle ,image) ,rectangle) + ,@body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) + +(defmacro with-clipping-rectangle* ((x1 y1 x2 y2 &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to the +rectangle with upper left corner \(X1, Y1) and lower right corner +\(X2, Y2). The previous clipping rectangle is guaranteed to be +restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (x1 y1 x2 y2 image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (set-clipping-rectangle* ,x1 ,y1 ,x2 ,y2 ,image) + ,@body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/gd-uffi.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/gd-uffi.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,731 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.32 2007/04/05 23:22:24 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +;; internal representation of an image in GD +(def-struct gd-image + (pixels (* (* :unsigned-char))) + (sx :int) + (sy :int) + (colors-total :int) + (red (:array :int #.+max-colors+)) + (green (:array :int #.+max-colors+)) + (blue (:array :int #.+max-colors+)) + (open (:array :int #.+max-colors+)) + (transparent :int) + (poly-ints (* :int)) + (poly-allocated :int) + (brush :pointer-self) + (tile :pointer-self) + (brush-color-map (:array :int #.+max-colors+)) + (tile-color-map (:array :int #.+max-colors+)) + (style-length :int) + (style-pos :int) + (style (* :int)) + (interface :int) + (thick :int) + (alpha (:array :int #.+max-colors+)) + (true-color :int) + (t-pixels (* (* :int))) + (alpha-blending-flag :int) + (save-alpha-flag :int) + (aa :int) + (aa-color :int) + (aa-do-not-blend :int) + (aa-opacity (* (* :unsigned-char))) + (aa-polygon :int) + (aal-x1 :int) + (aal-y1 :int) + (aal-x2 :int) + (aal-y2 :int) + (aal-bx-ax :int) + (aal-by-ay :int) + (aal-lab-2 :int) + (aal-lab :float) + (cx1 :int) + (cy1 :int) + (cx2 :int) + (cy2 :int)) + +(def-type pixels-array (* (* :unsigned-char))) +(def-type pixels-row (* :unsigned-char)) +(def-type t-pixels-array (* (* :int))) +(def-type t-pixels-row (* :int)) + +(def-foreign-type gd-image-ptr (* gd-image)) + +;; initialize special variable +(setq *null-image* (make-image (make-null-pointer 'gd-image))) + +;; internal representation of a point in GD, used by the polygon +;; functions +(def-struct gd-point + (x :int) + (y :int)) + +(def-foreign-type gd-point-ptr (* gd-point)) + +;; internal representation of a font in GD, used by the (non-FreeType) +;; functions which draw characters and strings +(def-struct gd-font + (nchars :int) + (offset :int) + (w :int) + (h :int) + (data (* :char))) + +(def-foreign-type gd-font-ptr (* gd-font)) + +;; additional info for calls to the FreeType library - currently only +;; used for line spacing +(def-struct gd-ft-string-extra + (flags :int) + (line-spacing :double) + (charmap :int)) + +(def-foreign-type gd-ft-string-extra-ptr (* gd-ft-string-extra)) + +;; the GD standard fonts used when drawing characters or strings +;; without invoking the FreeType library +(def-foreign-var ("gdFontTiny" +gd-font-tiny+) gd-font-ptr "gd") +(def-foreign-var ("gdFontSmall" +gd-font-small+) gd-font-ptr "gd") +(def-foreign-var ("gdFontMediumBold" +gd-font-medium-bold+) gd-font-ptr "gd") +(def-foreign-var ("gdFontLarge" +gd-font-large+) gd-font-ptr "gd") +(def-foreign-var ("gdFontGiant" +gd-font-giant+) gd-font-ptr "gd") + +;;; all GD functions which are accessed from CL-GD + +(def-function ("gdImageCreate" gd-image-create) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateTrueColor" gd-image-create-true-color) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromJpegFile" gd-image-create-from-jpeg-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromPngFile" gd-image-create-from-png-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGdFile" gd-image-create-from-gd-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2File" gd-image-create-from-gd2-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2PartFile" gd-image-create-from-gd2-part-file) + ((filename :cstring) + (err (* :int)) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromXbmFile" gd-image-create-from-xbm-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +#-:win32 +(def-function ("gdImageCreateFromXpm" gd-image-create-from-xpm) + ((filename :cstring)) + :returning gd-image-ptr + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageCreateFromGifFile" gd-image-create-from-gif-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageJpegPtr" gd-image-jpeg-ptr) + ((im gd-image-ptr) + (size (* :int)) + (quality :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGdPtr" gd-image-gd-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGd2Ptr" gd-image-gd2-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageWBMPPtr" gd-image-wbmp-ptr) + ((im gd-image-ptr) + (size (* :int)) + (fg :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtr" gd-image-png-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtrEx" gd-image-png-ptr-ex) + ((im gd-image-ptr) + (size (* :int)) + (level :int)) + :returning :pointer-void + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageGifPtr" gd-image-gif-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageDestroy" gd-image-destroy) + ((im gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageColorAllocate" gd-image-color-allocate) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorAllocateAlpha" gd-image-color-allocate-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorDeallocate" gd-image-color-deallocate) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageColorExact" gd-image-color-exact) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosest" gd-image-color-closest) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestHWB" gd-image-color-closest-hwb) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestAlpha" gd-image-color-closest-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolve" gd-image-color-resolve) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolveAlpha" gd-image-color-resolve-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorTransparent" gd-image-color-transparent) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetTransparent" gd-image-get-transparent) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetAntiAliased" gd-image-set-anti-aliased) + ((im gd-image-ptr) + (c :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetAntiAliasedDontBlend" gd-image-set-anti-aliased-do-not-blend) + ((im gd-image-ptr) + (c :int) + (dont-blend :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetBrush" gd-image-set-brush) + ((im gd-image-ptr) + (brush gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetTile" gd-image-set-tile) + ((im gd-image-ptr) + (tile gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetStyle" gd-image-set-style) + ((im gd-image-ptr) + (style (* :int)) + (style-length :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetThickness" gd-image-set-thickness) + ((im gd-image-ptr) + (thickness :int)) + :returning :void + :module "gd") + +(def-function ("gdImageAlphaBlending" gd-image-alpha-blending) + ((im gd-image-ptr) + (blending :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSaveAlpha" gd-image-save-alpha) + ((im gd-image-ptr) + (save-flag :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetRed" gd-image-get-red) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetGreen" gd-image-get-green) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetBlue" gd-image-get-blue) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetAlpha" gd-image-get-alpha) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetColorsTotal" gd-image-get-colors-total) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetClip" gd-image-set-clip) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetClip" gd-image-get-clip) + ((im gd-image-ptr) + (x1p (* :int)) + (y1p (* :int)) + (x2p (* :int)) + (y2p (* :int))) + :returning :void + :module "gd") + +(def-function ("gdImageSetPixel" gd-image-set-pixel) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageLine" gd-image-line) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePolygon" gd-image-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledPolygon" gd-image-filled-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageRectangle" gd-image-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledRectangle" gd-image-filled-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledEllipse" gd-image-filled-ellipse) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageArc" gd-image-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledArc" gd-image-filled-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int) + (style :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFill" gd-image-fill) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFillToBorder" gd-image-fill-to-border) + ((im gd-image-ptr) + (x :int) + (y :int) + (border :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageChar" gd-image-char) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCharUp" gd-image-char-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageString" gd-image-string) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringUp" gd-image-string-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringFT" gd-image-string-ft) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring)) + :returning :cstring + :module "gd") + +(def-function ("gdImageStringFTEx" gd-image-string-ft-ex) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring) + (strex gd-ft-string-extra-ptr)) + :returning :cstring + :module "gd") + +(def-function ("gdImageGetPixel" gd-image-get-pixel) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageBoundsSafe" gd-image-bounds-safe) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSX" gd-image-get-sx) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSY" gd-image-get-sy) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageInterlace" gd-image-interlace) + ((im gd-image-ptr) + (interlace :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetInterlaced" gd-image-get-interlaced) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageCopy" gd-image-copy) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMerge" gd-image-copy-merge) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMergeGray" gd-image-copy-merge-gray) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResized" gd-image-copy-resized) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResampled" gd-image-copy-resampled) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyRotated" gd-image-copy-rotated) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :double) + (dst-y :double) + (src-x :int) + (src-y :int) + (src-w :int) + (src-h :int) + (angle :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePaletteCopy" gd-image-palette-copy) + ((dst gd-image-ptr) + (src gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageCompare" gd-image-compare) + ((im1 gd-image-ptr) + (im2 gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageTrueColorToPalette" gd-image-true-color-to-palette) + ((im gd-image-ptr) + (dither :int) + (colors-wanted :int)) + :returning :void + :module "gd") + +(def-function ("gdFree" gd-free) + ((ptr :pointer-void)) + :returning :void + :module "gd") Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/images.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/images.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,411 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/images.lisp,v 1.33 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun create-image (width height &optional true-color) + "Allocates and returns a GD image structure with size WIDTH x +HEIGHT. Creates a true color image if TRUE-COLOR is true. You are +responsible for destroying the image after you're done with it. It is +advisable to use WITH-IMAGE instead." + (check-type width integer) + (check-type height integer) + (let ((image-ptr + (if true-color + (gd-image-create-true-color width height) + (gd-image-create width height)))) + (when (null-pointer-p image-ptr) + (error "Could not allocate image of size ~A x ~A" width height)) + (let ((image (make-image image-ptr))) + image))) + +(defun destroy-image (image) + "Destroys \(deallocates) IMAGE which has been created by +CREATE-IMAGE, CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART." + (check-type image image) + (gd-image-destroy (img image)) + nil) + +(defmacro with-default-image ((image) &body body) + "Executes BODY with *DEFAULT-IMAGE* bound to IMAGE so that you don't +have to provide the IMAGE keyword/optional argument to CL-GD +functions." + `(let ((*default-image* ,image)) + ,@body)) + +(defmacro with-image ((name width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT, and executes BODY with +the image bound to NAME. If TRUE-COLOR is true, creates a true color +image. The image is guaranteed to be destroyed before this macro +exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (width height true-color) + `(with-safe-alloc (,name + (create-image ,width ,height ,true-color) + (destroy-image ,name)) + ,@body))) + +(defmacro with-image* ((width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT and executes BODY with +the image bound to *DEFAULT-IMAGE*. If TRUE-COLOR is true, creates a +true color image. The image is guaranteed to be destroyed before this +macro exits." + `(with-image (*default-image* ,width ,height ,true-color) + ,@body)) + +(defun create-image-from-file (file-name &optional type) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string). The type of the image can be provided +as TYPE or otherwise it will be guessed from the PATHNAME-TYPE of +FILE-NAME. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead." + (check-type file-name (or pathname string)) + (let* ((pathname-type (pathname-type file-name)) + (%type (or type + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + ((string-equal pathname-type "xbm") + :xbm) + #-:win32 + ((string-equal pathname-type "xpm") + :xpm) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif))))) + (unless %type + (error "No type provided and it couldn't be guessed from filename")) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (ecase %type + ((:jpg :jpeg) + (gd-image-create-from-jpeg-file c-file-name err)) + ((:png) + (gd-image-create-from-png-file c-file-name err)) + ((:gd) + (gd-image-create-from-gd-file c-file-name err)) + ((:gd2) + (gd-image-create-from-gd2-file c-file-name err)) + ((:xbm) + (gd-image-create-from-xbm-file c-file-name err)) + #-:win32 + ((:xpm) + (gd-image-create-from-xpm c-file-name)) + #-:cl-gd-no-gif + ((:gif) + (gd-image-create-from-gif-file c-file-name err))))) + (cond ((null-pointer-p image) + (cond ((or (eq %type :xpm) + (zerop (deref-pointer err :int))) + (error "Could not create image from ~A file ~S" + %type file-name)) + (t + (error "Could not create image from ~A file ~S: errno was ~A" + %type file-name (deref-pointer err :int))))) + (t (let ((image (make-image image))) + image)))))))) + +(defmacro with-image-from-file ((name file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to NAME. The type of the image can be provied as TYPE or otherwise it +will be guessed from the PATHNAME-TYPE of FILE-NAME. The image is +guaranteed to be destroyed before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name type) + `(with-safe-alloc (,name + (create-image-from-file ,file-name ,type) + (destroy-image ,name)) + ,@body))) + +(defmacro with-image-from-file* ((file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to *DEFAULT-IMAGE*. The type of the image can be provied as TYPE or +otherwise it will be guessed from the PATHNAME-TYPE of FILE-NAME. The +image is guaranteed to be destroyed before this macro exits." + `(with-image-from-file (*default-image* ,file-name ,type) + ,@body)) + +(defun create-image-from-gd2-part (file-name src-x src-y width height) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified by SRC-X, SRC-Y, WIDTH, and +HEIGHT. You are responsible for destroying the image after you're done +with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead." + (check-type file-name (or string pathname)) + (check-type src-x integer) + (check-type src-y integer) + (check-type width integer) + (check-type height integer) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (gd-image-create-from-gd2-part-file c-file-name err src-x src-y width height))) + (cond ((null-pointer-p image) + (error "Could not create GD2 image from file ~S: errno was ~A" + file-name (deref-pointer err :int))) + (t image)))))) + +(defmacro with-image-from-gd2-part ((name file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to NAME. The type of the +image can be provied as TYPE or otherwise it will be guessed from the +PATHNAME-TYPE of FILE-NAME. The image is guaranteed to be destroyed +before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name src-x src-y width height) + `(with-safe-alloc (,name + (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height) + (destroy-image ,name)) + ,@body))) + +(defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to *DEFAULT-IMAGE*. The +type of the image can be provied as TYPE or otherwise it will be +guessed from the PATHNAME-TYPE of FILE-NAME. The image is guaranteed +to be destroyed before this macro exits." + `(with-image-from-gd2-part (*default-image* ,file-name ,src-x ,src-y ,width ,height) + ,@body)) + +(defmacro make-stream-fn (name signature gd-call type-checks docstring) + "Internal macro used to generate WRITE-JPEG-TO-STREAM and friends." + `(defun ,name ,signature + ,docstring + ,@type-checks + (cond ((or #+(and :allegro :allegro-version>= (version>= 6 0)) + (typep stream 'excl:simple-stream) + #+:lispworks4.3 + (subtypep 'base-char (stream-element-type stream)) + (subtypep '(unsigned-byte 8) (stream-element-type stream))) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (let (#+:lispworks4.3 + (temp-array (make-array 1 :element-type + '(unsigned-byte 8)))) + (with-cast-pointer (temp memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + ;; LispWorks workaround, WRITE-BYTE won't work - see + ;; <http://article.gmane.org/gmane.lisp.lispworks.general/1827> + #+:lispworks4.3 + (setf (aref temp-array 0) + (deref-array temp '(:array :unsigned-byte) i)) + #+:lispworks4.3 + (write-sequence temp-array stream) + #-:lispworks4.3 + (write-byte (deref-array temp '(:array :unsigned-byte) i) + stream)) + image))))) + ((subtypep 'character (stream-element-type stream)) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (with-cast-pointer (temp memory + #+(or :cmu :scl :sbcl) :unsigned-char + #-(or :cmu :scl :sbcl) :char) + (dotimes (i (deref-pointer size :int)) + (write-char (ensure-char-character + (deref-array temp '(:array :char) i)) + stream)) + image)))) + (t (error "Can't use a stream with element-type ~A" + (stream-element-type stream)))))) + +(make-stream-fn write-jpeg-to-stream (stream &key (quality -1) (image *default-image*)) + (gd-image-jpeg-ptr (img image) size quality) + ((check-type stream stream) + (check-type quality (integer -1 100)) + (check-type image image)) + "Writes image IMAGE to stream STREAM as JPEG. If +QUALITY is not specified, the default IJG JPEG quality value is +used. Otherwise, for practical purposes, quality should be a value in +the range 0-95. STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format is +yields faithful output of all 8-bit characters.") + +(make-stream-fn write-png-to-stream (stream &key compression-level (image *default-image*)) + (cond (compression-level + (gd-image-png-ptr-ex (img image) size compression-level)) + (t + (gd-image-png-ptr (img image) size))) + ((check-type stream stream) + (check-type compression-level (or null (integer -1 9))) + (check-type image image)) + "Writes image IMAGE to stream STREAM as PNG. If +COMPRESSION-LEVEL is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of +1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format yields +faithful output of all 8-bit characters.") + +#-:cl-gd-no-gif +(make-stream-fn write-gif-to-stream (stream &key (image *default-image*)) + (gd-image-gif-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GIF. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-wbmp-to-stream (stream &key foreground (image *default-image*)) + (gd-image-wbmp-ptr (img image) size foreground) + ((check-type stream stream) + (check-type foreground integer) + (check-type image image)) + "Writes image IMAGE to stream STREAM as WBMP. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters. WBMP file support is black and white +only. The color index specified by the FOREGOUND argument is the +\"foreground,\" and only pixels of this color will be set in the WBMP +file") + +(make-stream-fn write-gd-to-stream (stream &key (image *default-image*)) + (gd-image-gd-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-gd2-to-stream (stream &key (image *default-image*)) + (gd-image-gd2-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(defun write-image-to-stream (stream type &rest rest &key &allow-other-keys) + "Writes image to STREAM. The type of the image is determined by TYPE +which must be one of :JPG, :JPEG, :PNG, :WBMP, :GD, or :GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters." + (apply (ecase type + ((:jpg :jpeg) + #'write-jpeg-to-stream) + ((:png) + #'write-png-to-stream) + ((:wbmp) + #'write-wbmp-to-stream) + ((:gd) + #'write-gd-to-stream) + ((:gd2) + #'write-gd2-to-stream) + #-:cl-gd-no-gif + ((:gif) + #'write-gif-to-stream)) + stream rest)) + +(defun write-image-to-file (file-name &rest rest &key type (if-exists :error) &allow-other-keys) + "Writes image to the file specified by FILE-NAME \(a pathname or a +string). The TYPE argument is interpreted as in +WRITE-IMAGE-TO-STREAM. If it is not provided it is guessed from the +PATHNAME-TYPE of FILE-NAME. The IF-EXISTS keyword argument is given to +OPEN. Other keyword argument like QUALITY or COMPRESSION-LEVEL can be +provided depending on the images's type." + (with-open-file (stream file-name :direction :output + :if-exists if-exists + :element-type '(unsigned-byte 8)) + (apply #'write-image-to-stream + stream + (or type + (let ((pathname-type (pathname-type (truename file-name)))) + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "wbmp") + :wbmp) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif) + (t + (error "Can't determine the type of the image"))))) + (sans rest :type :if-exists)))) + +(defun image-width (&optional (image *default-image*)) + "Returns width of IMAGE." + (check-type image image) + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer)) + (gd-image-get-sx (img image)))) + +(defun image-height (&optional (image *default-image*)) + (check-type image image) + "Returns height of IMAGE." + (with-transformed-alternative + (((gd-image-get-sy (img image)) h-inv-transformer)) + (gd-image-get-sy (img image)))) + +(defun image-size (&optional (image *default-image*)) + (check-type image image) + "Returns width and height of IMAGE as two values." + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer) + ((gd-image-get-sy (img image)) h-inv-transformer)) + (values (gd-image-get-sx (img image)) + (gd-image-get-sy (img image))))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/init.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/init.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,46 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/init.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun load-gd-glue () + "Load the little glue library we have to create for the image input +functions." + ;; try to find the library at different places + (let ((filename (find-foreign-library "cl-gd-glue" + *shared-library-directories* + :types *shared-library-types* + :drive-letters *shared-library-drive-letters*))) + (load-foreign-library filename + :module "gd" + :supporting-libraries *gd-supporting-libraries*))) + +;; invoke the function, i.e. load the library (and thus GD itself) +;; before gd-uffi.lisp is loaded/compiled +(load-gd-glue) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,238 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/misc.lisp,v 1.15 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun interlacedp (&optional (image *default-image*)) + "Returns whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (not (zerop (gd-image-get-interlaced (img image))))) + +(defun (setf interlacedp) (interlaced &optional (image *default-image*)) + "Sets whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (gd-image-interlace (img image) (if interlaced 1 0)) + interlaced) + +(defun differentp (image1 image2) + "Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images." + (check-type image1 image) + (check-type image2 image) + (let ((result (gd-image-compare (img image1) (img image2)))) + (cond ((zerop (logand +gd-cmp-image+ result)) + nil) + (t + (loop for (gd-flag keyword) in `((,+gd-cmp-num-colors+ + :different-number-of-colors) + (,+gd-cmp-color+ + :different-colors) + (,+gd-cmp-size-x+ + :different-widths) + (,+gd-cmp-size-y+ + :different-heights) + (,+gd-cmp-transparent+ + :different-transparent-colors) + (,+gd-cmp-background+ + :different-background-colors) + (,+gd-cmp-interlace+ + :different-interlace-settings) + (,+gd-cmp-true-color+ + :true-color-versus-palette-based)) + when (plusp (logand gd-flag result)) + collect keyword))))) + +(defun copy-image (source destination + source-x source-y + dest-x dest-y + width height + &key resample + rotate angle + resize dest-width dest-height + merge merge-gray) + "Copies \(a part of) image SOURCE into image DESTINATION. Copies the +rectangle with the upper left corner \(SOURCE-X,SOURCE-Y) and size +WIDTH x HEIGHT to the rectangle with the upper left corner +\(DEST-X,DEST-Y). + +If RESAMPLE is true pixel colors will be smoothly interpolated. If +RESIZE is true the copied rectangle will be strechted or shrinked so +that its size is DEST-WIDTH x DEST-HEIGHT. If ROTATE is true the image +will be rotated by ANGLE. In this particular case DEST-X and DEST-Y +specify the CENTER of the copied image rather than its upper left +corner! If MERGE is true it has to be an integer in the range 0-100 +and the two images will be 'merged' by the amount specified. If MERGE +is 100 then the source image will simply be copied. If instead +MERGE-GRAY is true the hue of the source image is preserved by +converting the destination area to gray pixels before merging. + +The keyword options RESAMPLE, ROTATE, RESIZE, MERGE, and MERGE-GRAY +are mutually exclusive \(with the exception of RESAMPLE and +RESIZE). ANGLE is assumed to be specified in degrees if it's an +integer, and in radians otherwise." + (check-type source image) + (check-type destination image) + (check-type source-x integer) + (check-type source-y integer) + (unless rotate + (check-type dest-x integer) + (check-type dest-y integer)) + (check-type width integer) + (check-type height integer) + (check-type angle (or null number)) + (check-type dest-width (or null integer)) + (check-type dest-height (or null integer)) + (check-type merge (or null (integer 0 100))) + (check-type merge-gray (or null (integer 0 100))) + (when (and merge merge-gray) + (error "You can't specify MERGE and MERGE-GRAY at the same time.")) + (when (and (or merge merge-gray) + (or resample rotate resize)) + (error "MERGE and MERGE-GRAY can't be combined with RESAMPLE, ROTATE, or RESIZE.")) + (when (and (or dest-width dest-height) + (not resize)) + (error "Use RESIZE if you want to specify DEST-WIDTH or DEST-HEIGHT")) + (when (and resize + (not (or dest-width dest-height))) + (error "Please specify DEST-WIDTH and DEST-HEIGHT together with RESIZE.")) + (when (and angle + (not rotate)) + (error "Use ROTATE if you want to specify ANGLE.")) + (when (and rotate + (not angle)) + (error "Please specify ANGLE together with ROTATE.")) + (when (and rotate + (or resample resize)) + (error "ROTATE can't be used together with RESAMPLE or RESIZE.")) + (cond ((and resample resize) + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (resample + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + width height width height)) + ((and rotate (integerp angle)) + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height angle)) + (rotate + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height + (round (* angle +radians-to-degree-factor+)))) + (resize + (gd-image-copy-resized (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (merge + (gd-image-copy-merge (img destination) (img source) + dest-x dest-y source-x source-y + width height merge)) + (merge-gray + (gd-image-copy-merge-gray (img destination) (img source) + dest-x dest-y source-x source-y + width height merge-gray)) + (t + (gd-image-copy (img destination) (img source) dest-x dest-y + source-x source-y width height))) + destination) + +(defun copy-palette (source destination) + "Copies palette of image SOURCE to image DESTINATION attempting to +match the colors in the target image to the colors in the source +palette." + (check-type source image) + (check-type destination image) + (gd-image-palette-copy (img destination) (img source)) + destination) + +(defun true-color-to-palette (&key dither (colors-wanted 256) (image *default-image*)) + "Converts the true color image IMAGE to a palette-based image using +a high-quality two-pass quantization routine. If DITHER is true, the +image will be dithered to approximate colors better, at the expense of +some obvious \"speckling.\" COLORS-WANTED can be any positive integer +up to 256 \(which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image." + (check-type image image) + (check-type colors-wanted (integer 0 256)) + (gd-image-true-color-to-palette (img image) + (if dither 1 0) + colors-wanted) + image) + +(defmacro do-rows ((y-var &optional (image '*default-image*)) &body body) + (with-rebinding (image) + (with-unique-names (img width height true-color-p raw-pixels row x-var inner-body) + `(let* ((,img (img ,image)) + (,width (gd-image-get-sx ,img)) + (,height (gd-image-get-sy ,img)) + (,true-color-p (true-color-p ,image))) + (declare (fixnum ,width ,height)) + (cond (,true-color-p + (let ((,raw-pixels (get-slot-value ,img 'gd-image 't-pixels))) + (declare (type t-pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :int)) ,y-var))) + (declare (type t-pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :int) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + ,@body)))))) + (t + (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) + (declare (type pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-char)) ,y-var))) + (declare (type pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :unsigned-char) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + ,@body))))))))))) + +(defmacro do-pixels ((&optional (image '*default-image*)) &body body) + (with-unique-names (x y) + `(do-rows (,y ,image) + (do-pixels-in-row (,x) + ,@body)))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/packages.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,80 @@ +(in-package #:cl-user) + +(defpackage #:cl-gd + (:use #:cl #:uffi) + (:export #:*default-image* + #:*default-color* + #:*default-font* + #:+max-colors+ + #:without-transformations + #:with-transformation + #:create-image + #:destroy-image + #:with-image + #:create-image-from-file + #:with-image-from-file + #:create-image-from-gd2-part + #:with-image-from-gd2-part + #:with-default-image + #:with-image* + #:with-image-from-file* + #:with-image-from-gd2-part* + #:write-jpeg-to-stream + #:write-png-to-stream + #:write-wbmp-to-stream + #:write-gd-to-stream + #:write-gd2-to-stream + #-:cl-gd-no-gif #:write-gif-to-stream + #:write-image-to-stream + #:write-image-to-file + #:image-width + #:image-height + #:image-size + #:make-brush + #:make-tile + #:make-anti-aliased + #:with-default-color + #:allocate-color + #:deallocate-color + #:transparent-color + #:true-color-p + #:number-of-colors + #:find-color + #:find-color-from-image + #:thickness + #:with-thickness + #:alpha-blending-p + #:save-alpha-p + #:color-component + #:color-components + #:draw-polygon + #:draw-line + #:get-pixel + #:set-pixel + #:set-pixels + #:draw-rectangle + #:draw-rectangle* + #:draw-arc + #:draw-filled-ellipse + #:draw-filled-circle + #:fill-image + #:clipping-rectangle + #:clipping-rectangle* + #:set-clipping-rectangle* + #:with-clipping-rectangle + #:with-clipping-rectangle* + #:with-default-font + #:draw-character + #:draw-string + #:draw-freetype-string + #:interlacedp + #:differentp + #:copy-image + #:copy-palette + #:true-color-to-palette + #:do-rows + #:do-pixels-in-row + #:do-pixels + #:raw-pixel)) + +(pushnew :cl-gd *features*) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/specials.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/specials.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,173 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/specials.lisp,v 1.29 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package #:cl-gd) + +(defvar *default-image* nil + "The default image. This special variable is usually bound by +WITH-IMAGE or WITH-IMAGE-FROM-FILE.") + +(defvar *default-color* nil + "The default color. This special variable is usually bound by +WITH-COLOR.") + +(defvar *default-font* nil + "The default font. This special variable is usually bound by +WITH-FONT.") + +(defstruct (image + (:conc-name nil) + (:constructor make-image (img)) + (:copier nil)) + img) + +(defstruct (brush + (:include image) + (:constructor %make-brush (img)) + (:copier nil))) + +(defun make-brush (image) + (%make-brush (img image))) + +(defstruct (tile + (:include image) + (:constructor %make-tile (img)) + (:copier nil))) + +(defun make-tile (image) + (%make-tile (img image))) + +(defstruct (anti-aliased-color + (:conc-name nil) + (:constructor %make-anti-aliased (color do-not-blend)) + (:copier nil)) + color do-not-blend) + +(defun make-anti-aliased (color &optional do-not-blend) + (%make-anti-aliased color do-not-blend)) + +;; the following variable will be initialized in "gd-uffi.lisp" +(defvar *null-image* nil + "A 'null' image which might be useful for DRAW-FREETYPE-STRING.") + +(defconstant +max-colors+ 256 + "Maximum number of colors for palette-based images.") + +(defconstant +gd-chord+ 1 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-no-fill+ 2 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-edged+ 4 + "Used internally by GD-FILLED-ARC") + +(defconstant +brushed+ -3 + "Special 'color' for lines drawn with brush.") +(defconstant +styled+ -2 + "Special 'color' for styled lines.") +(defconstant +styled-brushed+ -4 + "Special 'color' for lines drawn with styled brush.") +(defconstant +transparent+ -6 + "Special 'color' used in GD function 'gdImageSetStyle' for transparent color.") +(defconstant +tiled+ -5 + "Special fill 'color' used for tiles.") +(defconstant +anti-aliased+ -7 + "Special 'color' for anti-aliased lines.") + +(defconstant +gd-ftex-linespace+ 1 + "Indicate line-spacing for FreeType library.") + +(defconstant +gd-cmp-image+ 1 + "Images will appear different when displayed.") +(defconstant +gd-cmp-num-colors+ 2 + "Number of colors in palette differ.") +(defconstant +gd-cmp-color+ 4 + "Image colors differ.") +(defconstant +gd-cmp-size-x+ 8 + "Image widths differ.") +(defconstant +gd-cmp-size-y+ 16 + "Image heights differ.") +(defconstant +gd-cmp-transparent+ 32 + "Transparent color is different.") +(defconstant +gd-cmp-background+ 64 + "Background color is different.") +(defconstant +gd-cmp-interlace+ 128 + "Interlace settings are different.") +(defconstant +gd-cmp-true-color+ 256 + "One image is a true-color image, the other one is palette-based.") + +(defvar *shared-library-directories* + `(,(namestring (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + "/usr/local/lib/" + "/usr/lib/" + "/usr/lib/cl-gd/" + "/cygwin/usr/local/lib/" + "/cygwin/usr/lib/") + "A list of directories where UFFI tries to find cl-gd-glue.so") +(defvar *shared-library-types* '("so" "dll" "dylib") + "The list of types a shared library can have. Used when looking for +cl-gd-glue.so") +(defvar *shared-library-drive-letters* '("C" "D" "E" "F" "G") + "The list of drive letters \(used by Wintendo) used when looking for +cl-gd-glue.dll.") + +(defvar *gd-supporting-libraries* '("c" "gd" "png" "z" "jpeg" "freetype" "iconv" "m") + "The libraries which are needed by cl-gd-glues.so \(and GD +itself). Only needed for Python-based Lisps like CMUCL, SBCL, or +SCL.") + +(defconstant +radians-to-degree-factor+ (/ 360 (* 2 pi)) + "Factor to convert from radians to degrees.") + +(defvar *transformers* nil + "Stack of currently active transformer objects.") + +(defconstant +most-positive-unsigned-byte-32+ + (1- (expt 2 31)) + "Name says it all...") + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see <http://common-lisp.net/project/hyperdoc/> +;; and <http://www.cliki.net/hyperdoc> + +(defvar *hyperdoc-base-uri* "http://weitz.de/cl-gd/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl-gd + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/strings.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/strings.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,194 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/strings.lisp,v 1.23 2007/04/24 09:01:39 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-font ((font) &body body) + "Execute BODY with *DEFAULT-FONT* bound to FONT so that you +don't have to provide the FONT keyword/optional argument to +string functions. But note that the fonts used for +DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are +incompatible." + `(let ((*default-font* ,font)) + ,@body)) + +(defun draw-character (x y char &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the character CHAR from font FONT in color COLOR at position +\(X,Y). If UP is true the character will be drawn from bottom to top +\(rotated 90 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, +:LARGE, :GIANT." + (check-type char character) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if up + (gd-image-char-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color) + (gd-image-char (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color)))) + char) + +(defun draw-string (x y string &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y). If UP is +true the character will be drawn from bottom to top \(rotated 90 +degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, :LARGE, :GIANT." + (check-type string string) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (with-cstring (c-string string) + (if up + (gd-image-string-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color) + (gd-image-string (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color))))) + string) + +(defun draw-freetype-string (x y string + &key (anti-aliased t) + (point-size 12.0d0) + (angle 0.0d0) + (convert-chars t) + line-spacing + (font-name *default-font*) + do-not-draw + (color *default-color*) + (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y) using the +FreeType library. FONT-NAME is the full path \(a pathname or a string) +to a TrueType font file, or a font face name if the GDFONTPATH +environment variable or FreeType's DEFAULT_FONTPATH variable have been +set intelligently. The string may be arbitrarily scaled \(POINT-SIZE) +and rotated \(ANGLE in radians). The direction of rotation is +counter-clockwise, with 0 radians \(0 degrees) at 3 o'clock and PI/2 +radians \(90 degrees) at 12 o'clock. Note that the ANGLE argument is +purposefully _not_ affected by WITH-TRANSFORMATION. If ANTI-ALIASED if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +LINE-SPACING, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like \"À\". If CONVERT-CHARS is true \(which is the default) +characters of STRING with CHAR-CODE greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's CHAR-CODE +function returns ISO/IEC 10646 (Unicode) character codes. + +The return value is an array containing 8 elements representing the 4 +corner coordinates \(lower left, lower right, upper right, upper left) +of the bounding rectangle around the string that was drawn. The points +are relative to the text regardless of the angle, so \"upper left\" +means in the top left-hand corner seeing the text horizontally. Set +DO-NOT-DRAW to true to get the bounding rectangle without +rendering. This is a relatively cheap operation if followed by a +rendering of the same string, because of the caching of the partial +rendering during bounding rectangle calculation." + (check-type string string) + (check-type font-name (or pathname string)) + (unless do-not-draw + (check-type color integer) + (check-type image image)) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer) + ((deref-array c-bounding-rectangle '(:array :int) i) x-inv-transformer) + ((deref-array c-bounding-rectangle '(:array :int) (1+ i)) y-inv-transformer)) + (when do-not-draw + (setq color 0 + image *null-image*)) + (when (pathnamep font-name) + (setq font-name (namestring font-name))) + (when convert-chars + (setq string (convert-to-char-references string))) + (with-cstring (c-font-name font-name) + (with-cstring (c-string string) + (with-safe-alloc (c-bounding-rectangle + (allocate-foreign-object :int 8) + (free-foreign-object c-bounding-rectangle)) + (let ((msg (convert-from-cstring + (cond (line-spacing + (with-foreign-object (strex 'gd-ft-string-extra) + (setf (get-slot-value strex + 'gd-ft-string-extra + 'flags) + +gd-ftex-linespace+ + (get-slot-value strex + 'gd-ft-string-extra + 'line-spacing) + (coerce line-spacing 'double-float)) + (gd-image-string-ft-ex (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string + strex))) + (t + (gd-image-string-ft (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string)))))) + (when msg + (error "Error in FreeType library: ~A" msg)) + (let ((bounding-rectangle (make-array 8))) + ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE + (loop for i below 8 by 2 do + (setf (aref bounding-rectangle i) + (deref-array c-bounding-rectangle '(:array :int) i)) + (setf (aref bounding-rectangle (1+ i)) + (deref-array c-bounding-rectangle '(:array :int) (1+ i)))) + bounding-rectangle))))))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/demoin.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/brushed-arc.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/chart.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/circle.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/triangle.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/smallzappa.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/zappa.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/transform.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/transform.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,193 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.21 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defclass transformer () + ((image :initarg :image + :reader image) + (w-transformer :initarg :w-transformer + :reader w-transformer + :type function) + (h-transformer :initarg :h-transformer + :reader h-transformer + :type function) + (x-transformer :initarg :x-transformer + :reader x-transformer + :type function) + (y-transformer :initarg :y-transformer + :reader y-transformer + :type function) + (w-inv-transformer :initarg :w-inv-transformer + :reader w-inv-transformer + :type function) + (h-inv-transformer :initarg :h-inv-transformer + :reader h-inv-transformer + :type function) + (x-inv-transformer :initarg :x-inv-transformer + :reader x-inv-transformer + :type function) + (y-inv-transformer :initarg :y-inv-transformer + :reader y-inv-transformer + :type function) + (angle-transformer :initarg :angle-transformer + :reader angle-transformer + :type function)) + (:documentation "Class used internally for WITH-TRANSFORMATION +macro.")) + +(defmacro without-transformations (&body body) + "Executes BODY without any transformations applied." + `(let (*transformers*) + ,@body)) + +(declaim (inline round-to-c-int)) +(defun round-to-signed-byte-32 (x) + "Like ROUND but make sure result isn't longer than 32 bits." + (mod (round x) +most-positive-unsigned-byte-32+)) + +(defmacro with-transformation ((&key x1 x2 width y1 y2 height reverse-x reverse-y (radians t) (image '*default-image*)) &body body) + "Executes BODY such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of IMAGE will start at X1 and end at X2 and +have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at +Y2 and have length HEIGHT. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +REVERSE-X is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to REVERSE-Y, of course. If RADIANS is true angles inside of +BODY will be assumed to be provided in radians, otherwise in degrees." + (with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image) + (with-unique-names (image-width image-height + stretch-x stretch-y + w-transformer h-transformer + x-transformer y-transformer + w-inv-transformer h-inv-transformer + x-inv-transformer y-inv-transformer + angle-transformer) + ;; rebind for thread safety + `(let ((*transformers* *transformers*)) + (unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width))) + (error "You must provide at least two of X1, X2, and WIDTH.")) + (unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height))) + (error "You must provide at least two of Y1, Y2, and HEIGHT.")) + (when (and ,x1 ,x2 ,width + (/= ,width (- ,x2 ,x1))) + (error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments.")) + (when (and ,y1 ,y2 ,height + (/= ,height (- ,y2 ,y1))) + (error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments.")) + ;; kludgy code to keep SBCL quiet + (unless ,x1 (setq ,x1 (- ,x2 ,width))) + (unless ,x2 (setq ,x2 (+ ,x1 ,width))) + (unless ,width (setq ,width (- ,x2 ,x1))) + (unless ,y1 (setq ,y1 (- ,y2 ,height))) + (unless ,y2 (setq ,y2 (+ ,y1 ,height))) + (unless ,height (setq ,height (- ,y2 ,y1))) + (multiple-value-bind (,image-width ,image-height) + (without-transformations + (image-size ,image)) + (let* ((,stretch-x (/ ,image-width ,width)) + (,stretch-y (/ ,image-height ,height)) + (,w-transformer (lambda (w) + (round-to-signed-byte-32 + (* w ,stretch-x)))) + (,w-inv-transformer (lambda (w) + (/ w ,stretch-x))) + (,h-transformer (lambda (h) + (round-to-signed-byte-32 + (* h ,stretch-y)))) + (,h-inv-transformer (lambda (h) + (/ h ,stretch-y))) + (,x-transformer (if ,reverse-x + (lambda (x) + (round-to-signed-byte-32 + (* (- ,x2 x) ,stretch-x))) + (lambda (x) + (round-to-signed-byte-32 + (* (- x ,x1) ,stretch-x))))) + (,x-inv-transformer (if ,reverse-x + (lambda (x) + (- ,x2 (/ x ,stretch-x))) + (lambda (x) + (+ ,x1 (/ x ,stretch-x))))) + (,y-transformer (if ,reverse-y + (lambda (y) + (round-to-signed-byte-32 + (* (- y ,y1) ,stretch-y))) + (lambda (y) + (round-to-signed-byte-32 + (* (- ,y2 y) ,stretch-y))))) + (,y-inv-transformer (if ,reverse-y + (lambda (y) + (+ ,y1 (/ y ,stretch-y))) + (lambda (y) + (- ,y2 (/ y ,stretch-y))))) + (,angle-transformer (cond (,radians + (lambda (angle) + (round-to-signed-byte-32 + (* angle + +radians-to-degree-factor+)))) + (t + #'identity)))) + (push (make-instance 'transformer + :image ,image + :w-transformer ,w-transformer + :h-transformer ,h-transformer + :x-transformer ,x-transformer + :y-transformer ,y-transformer + :w-inv-transformer ,w-inv-transformer + :h-inv-transformer ,h-inv-transformer + :x-inv-transformer ,x-inv-transformer + :y-inv-transformer ,y-inv-transformer + :angle-transformer ,angle-transformer) + *transformers*) + (unwind-protect + (progn + ,@body) + (pop *transformers*)))))))) + +(defmacro with-transformed-alternative ((&rest transformations) &body body) + "Internal macro used to make functions +transformation-aware. TRANSFORMATION is a list of (EXPR +TRANSFORMATION) pairs where each EXPR will be replaced by the +transformation denoted by TRANSFORMATION." + (with-unique-names (transformer) + (let ((transformations-alist + (loop for (expr transformation) in transformations + collect `(,expr . (funcall (,transformation ,transformer) ,expr))))) + ;; note that we always use the name 'IMAGE' - no problem because + ;; this is a private macro + `(let ((,transformer (find image *transformers* :key #'image))) + (cond (,transformer + ,(sublis transformations-alist + `(progn ,@body) + :test #'equal)) + (t (progn + ,@body))))))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/util.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/util.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,136 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/util.lisp,v 1.15 2007/02/28 15:47:58 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +#+:lispworks +(import 'lw:with-unique-names) + +#-:lispworks +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + ,@body)) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (macro-function 'with-rebinding) + (macro-function 'lw:rebinding))) + +#-:lispworks +(defmacro with-rebinding (bindings &body body) + "REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,,@temps) + ,,@body)))))) + +(defun sans (plist &rest keys) + "Returns PLIST with keyword arguments from KEYS removed." + ;; stolen from Usenet posting <3247672165664225(a)naggum.no> by Erik + ;; Naggum + (let ((sans ())) + (loop + (let ((tail (nth-value 2 (get-properties plist keys)))) + ;; this is how it ends + (unless tail + (return (nreconc sans plist))) + ;; copy all the unmatched keys + (loop until (eq plist tail) do + (push (pop plist) sans) + (push (pop plist) sans)) + ;; skip the matched key + (setq plist (cddr plist)))))) + +(defun convert-to-char-references (string) + "Returns a string where all characters of STRING with CHAR-CODE +greater than 127 are converted to XML character entities." + (with-output-to-string (s) + (with-standard-io-syntax + (loop for char across string + for char-code = (char-code char) + when (<= char-code 127) do + (write-char char s) + else do + (write-char #\& s) + (write-char #\# s) + (princ char-code s) + (write-char #\; s))))) + +(defmacro with-safe-alloc ((var alloc free) &rest body) + `(let (,var) + (unwind-protect + (progn (setf ,var ,alloc) + ,@body) + (when ,var ,free)))) \ No newline at end of file

1 0

[bknr-cvs] r2427 - branches/bos/projects/bos/payment-website/templates/en
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 03:09:17 2008 New Revision: 2427 Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml Log: Rearrange a little to gain more screen space. Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Thu Jan 31 03:09:17 2008 @@ -67,23 +67,10 @@ <tr> <td class="Label">action message</td> <td class="Input"> - <button name="action" type="submit" value="save" onclick="javascript:return formcheck();">SAVE</button> - </td> - <td class="Info">Your personal profile data will be updated with the entered data.</td> - </tr> - <tr> - <td class="Label"></td> - <td class="Input"> - <button name="anonymize" type="submit" value="anonymize" onclick="javascript:return anonymizecheck();">make profile anonymous</button> - </td> - <td class="Info">Your personal data will be hidden.</td> - </tr> - <tr> - <td class="Label"></td> - <td class="Input"> + <button name="action" type="submit" value="save" onclick="javascript:return formcheck();">Save</button> <button name="action" type="reset">discard changes</button> </td> - <td class="Info">All arranged changes have been discarded.</td> + <td class="Info">Update profile or discard changes.</td> </tr> <bos:when-certificate> <tr>

1 0

[bknr-cvs] r2426 - in branches/bos/projects/bos: payment-website/templates/da payment-website/templates/de payment-website/templates/en web
by ksprotte＠common-lisp.net 31 Jan '08

31 Jan '08

Author: ksprotte Date: Thu Jan 31 02:16:47 2008 New Revision: 2426 Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml branches/bos/projects/bos/payment-website/templates/de/profil.xml branches/bos/projects/bos/payment-website/templates/en/profil.xml branches/bos/projects/bos/web/tags.lisp Log: Einbau eines Google Earth Links auf die Profilseite #15 Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/da/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/da/profil.xml Thu Jan 31 02:16:47 2008 @@ -55,7 +55,8 @@ </tr> <tr> <td class="Label">kvardratmeter</td> - <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt UTM-kordinater: N$(sqm-x) E$(sqm-y)</td> + <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt UTM-kordinater: N$(sqm-x) E$(sqm-y) + <a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/de/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/de/profil.xml Thu Jan 31 02:16:47 2008 @@ -60,7 +60,8 @@ </tr> <tr> <td class="Label">Quadratmeter</td> - <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft UTM-Koordinate: N$(sqm-x) E$(sqm-y)</td> + <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft UTM-Koordinate: N$(sqm-x) E$(sqm-y) + <a href="/contract-kml/$(contract-id)">Ihre Quadratmeter in Google Earth</a></td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Thu Jan 31 02:16:47 2008 @@ -60,7 +60,8 @@ </tr> <tr> <td class="Label">square metres</td> - <td class="Input">a total of $(numsqm) m² has been bought UTM-coordinate: N$(sqm-x) E$(sqm-y)</td> + <td class="Input">a total of $(numsqm) m² has been bought UTM-coordinate: N$(sqm-x) E$(sqm-y) + <a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Thu Jan 31 02:16:47 2008 @@ -147,7 +147,8 @@ (mapc #'emit-template-node children)) (define-bknr-tag save-profile (&key children) - (let ((sponsor (bknr-request-user (get-template-var :request)))) + (let* ((sponsor (bknr-request-user (get-template-var :request))) + (contract (first (sponsor-contracts sponsor)))) (with-template-vars (email name password infotext anonymize) (when anonymize (change-slot-values sponsor @@ -163,11 +164,12 @@ (when infotext (change-slot-values sponsor 'info-text infotext))) (setf (get-template-var :sponsor-id) (format nil "~D" (store-object-id sponsor))) + (setf (get-template-var :contract-id) (format nil "~D" (store-object-id contract))) (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) - (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor))))))) - (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor))))))) + (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) + (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) (setf (get-template-var :numsqm) (format nil "~D" (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))

1 0

[bknr-cvs] r2425 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 31 Jan '08

31 Jan '08

Author: ksprotte Date: Thu Jan 31 01:45:23 2008 New Revision: 2425 Modified: branches/bos/projects/bos/web/kml-handlers.lisp Log: Anzeige der Sponsor-Informationen wie in der Sat-App #17 Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Thu Jan 31 01:45:23 2008 @@ -6,12 +6,37 @@ (defun kml-format-color (color &optional (opacity 255)) (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) -(defun utf8-text (string) - ;; cxml::utf8-string-to-rod did not - ;; what we want, so we use utf-8-string-to-bytes - ;; instead +(defun utf-8-text (string) + ;; cxml::utf8-string-to-rod did not what we want, so we use + ;; utf-8-string-to-bytes instead (cxml:text (utf-8-string-to-bytes string))) +(defun contract-description (contract language) + (declare (ignore language)) + (let* ((sponsor (contract-sponsor contract)) + (name (user-full-name sponsor))) + (map 'string #'code-char + (with-xml-output (cxml:make-octet-vector-sink) + (with-element "div" + (with-element "table" + (with-element "tr" + (with-element "td" (text "Sponsor-ID:")) + (with-element "td" (text (princ-to-string (store-object-id sponsor))))) + (with-element "tr" + (with-element "td" (text "Name:")) + (with-element "td" (utf-8-text (if name name "[anonymous]")))) + (with-element "tr" + (with-element "td" (text "Land:")) + (with-element "td" (text (sponsor-country sponsor)))) + (with-element "tr" + (with-element "td" (text "gesponsort:")) + (with-element "td" (utf-8-text (format nil "~D m²" (length (contract-m2s contract)))))) + (with-element "tr" + (with-element "td" (text "seit:")) + (with-element "td" (text (format-date-time (contract-date contract) :show-time nil))))) + (when (sponsor-info-text sponsor) + (utf-8-text (sponsor-info-text sponsor)))))))) + (defclass contract-kml-handler (object-handler) ()) @@ -24,16 +49,16 @@ (let ((polygon (m2s-polygon-lon-lat (contract-m2s c))) (name (user-full-name (contract-sponsor c)))) (with-element "Placemark" - (with-element "name" (utf8-text (format nil "~A ~Dm²" - (if name name "anonymous") - (length (contract-m2s c))))) - (with-element "description" (utf8-text "a description")) + (with-element "name" (utf-8-text (format nil "~A ~Dm²" + (if name name "anonymous") + (length (contract-m2s c))))) + (with-element "description" (utf-8-text (contract-description c :de))) (with-element "Style" (attribute "id" "#region") (with-element "LineStyle" (with-element "color" (text "ffff3500"))) (with-element "PolyStyle" - (with-element "color" (text (kml-format-color (contract-color c) 175))))) + (with-element "color" (text (kml-format-color (contract-color c) 175))))) (with-element "Polygon" (with-element "styleUrl" "#region") (with-element "tessellate" (text "1")) @@ -44,10 +69,10 @@ ;; the center contract (when (eq c contract) (with-element "Placemark" - (with-element "name" (utf8-text "YOUR m²s!")) - (with-element "description" (utf8-text (format nil "~A ~Dm2" - (if name name "anonymous") - (length (contract-m2s c))))) + (with-element "name" (utf-8-text (format nil "~A ~Dm²" + (if name name "anonymous") + (length (contract-m2s c))))) + (with-element "description" (utf-8-text (contract-description c :de))) (with-element "Point" (with-element "coordinates" (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))

1 0

[bknr-cvs] r2424 - in branches/trunk-reorg: bknr/datastore/src/data bknr/modules/bug bknr/modules/mail bknr/modules/tamagotchi bknr/modules/text bknr/modules/url bknr/web/src bknr/web/src/images bknr/web/src/web projects/quickhoney/src
by hhubner＠common-lisp.net 30 Jan '08

30 Jan '08

Author: hhubner Date: Wed Jan 30 08:02:24 2008 New Revision: 2424 Modified: branches/trunk-reorg/bknr/datastore/src/data/blob.lisp branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp branches/trunk-reorg/bknr/modules/mail/register-handler.lisp branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp branches/trunk-reorg/bknr/modules/text/article-handlers.lisp branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/authorizer.lisp branches/trunk-reorg/bknr/web/src/web/event-log.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/sessions.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp branches/trunk-reorg/projects/quickhoney/src/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Log: First session handling fixes. Modified: branches/trunk-reorg/bknr/datastore/src/data/blob.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/blob.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/blob.lisp Wed Jan 30 08:02:24 2008 @@ -168,7 +168,7 @@ (with-open-file (s nblobs-pathname :direction :output) (write (n-blobs-per-directory subsystem) :stream s)))) -(defun delete-orphaned-blob-files () +(defun delete-orphaned-blob-files (&optional (cold-run t)) (dolist (blob-pathname (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)) (store-blob-root-pathname)))) (handler-case @@ -177,7 +177,9 @@ (object (find-store-object object-id))) (labels ((delete-orphan (pathname) (handler-case - (delete-file pathname) + (if cold-run + (format t "cold run, not deleting ~A~%" pathname) + (delete-file pathname)) (error (e) (warn "can't delete file ~A: ~A" pathname e))))) (cond Modified: branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -21,13 +21,13 @@ (defmethod handle-object-form ((handler bug-tracker-handler) action tracker) (with-bknr-page (:title #?"bug-tracker for $((mailinglist-name tracker))") - (when (admin-p (bknr-request-user)) + (when (admin-p (bknr-session-user)) (html ((:a :href (format nil "/edit-bug-tracker/~a" (store-object-id tracker))) "edit bug-tracker"))) (bug-tracker-page :bug-tracker-id (store-object-id tracker)))) (defmethod file-bug-report ((handler bug-tracker-handler) tracker) - (let ((user (bknr-request-user))) + (let ((user (bknr-session-user))) ;; XXX check user rights (with-query-params (name status priority description) (let ((bug-report (make-object 'bug-report @@ -58,9 +58,9 @@ (defmethod handle-object-form ((handler bug-report-handler) action report) (with-bknr-page (:title #?"bug-report") - (when (or (equal (bknr-request-user) + (when (or (equal (bknr-session-user) (bug-report-handler report)) - (admin-p (bknr-request-user))) + (admin-p (bknr-session-user))) (html ((:a :href (format nil "/edit-bug-report/~a" (store-object-id report))) "edit bug-report"))) (bug-page :bug-id (store-object-id report)))) @@ -68,7 +68,7 @@ (defmethod handle-object-form ((handler bug-report-handler) (action (eql :annotate)) report) (if report - (let ((user (bknr-request-user))) + (let ((user (bknr-session-user))) (with-query-params (title text) (let ((article (make-object 'article :author user @@ -114,7 +114,7 @@ (defmethod handle-object-form ((handler edit-bug-tracker-handler) (action (eql :save)) tracker) - (if (admin-p (bknr-request-user)) + (if (admin-p (bknr-session-user)) (with-query-params (name email description) (change-slot-values tracker 'name name 'email email 'description description) (call-next-method)) @@ -144,8 +144,8 @@ (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :save)) report) - (if (or (admin-p (bknr-request-user)) - (equal (bknr-request-user) + (if (or (admin-p (bknr-session-user)) + (equal (bknr-session-user) (bug-report-handler report))) (with-query-params (name status priority description) (let ((status-kw (make-keyword-from-string status)) @@ -171,8 +171,8 @@ (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :close)) report) - (if (or (admin-p (bknr-request-user)) - (equal (bknr-request-user) + (if (or (admin-p (bknr-session-user)) + (equal (bknr-session-user) (bug-report-handler report))) (progn (change-slot-values report 'closed (get-universal-time) @@ -187,8 +187,8 @@ (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :reopen)) report) - (if (or (admin-p (bknr-request-user)) - (equal (bknr-request-user) + (if (or (admin-p (bknr-session-user)) + (equal (bknr-session-user) (bug-report-handler report))) (progn (change-slot-values report 'closed nil @@ -203,8 +203,8 @@ (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :delete)) report) - (if (or (admin-p (bknr-request-user)) - (equal (bknr-request-user) + (if (or (admin-p (bknr-session-user)) + (equal (bknr-session-user) (bug-report-handler report))) (progn (let ((tracker (bug-report-tracker report))) @@ -220,9 +220,9 @@ (action (eql :handle)) report) (if (or (null (bug-report-handler report)) - (admin-p (bknr-request-user))) + (admin-p (bknr-session-user))) (progn - (change-slot-values report 'handler (bknr-request-user)) + (change-slot-values report 'handler (bknr-session-user)) (call-next-method)) (with-bknr-page (:title #?"Edit bug report") (:p "You can not become the handler of this bug report") Modified: branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -106,7 +106,7 @@ (with-query-params (email) (let ((user (find-user email))) (if user - (if (admin-p (bknr-request-user)) + (if (admin-p (bknr-session-user)) (html-subscription-info user) (progn (html (:p "Sending unsubscribe information to " (:princ-safe (user-email user)))) Modified: branches/trunk-reorg/bknr/modules/mail/register-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/register-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/register-handler.lisp Wed Jan 30 08:02:24 2008 @@ -109,7 +109,7 @@ :email email :subscribe-mailinglist mailinglist)) (website-url (and mailinglist (mailinglist-website-url mailinglist)))) - (if (admin-p (bknr-request-user)) + (if (admin-p (bknr-session-user)) (progn (confirm-registration registration) (html (:h2 "registration completed") Modified: branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -15,7 +15,7 @@ (let ((tamagotchi (object-handler-get-object handler))) (cond ((null tamagotchi) t) ((null (tamagotchi-owner tamagotchi)) t) - ((equal (bknr-request-user) (tamagotchi-owner tamagotchi)) t) + ((equal (bknr-session-user) (tamagotchi-owner tamagotchi)) t) (t nil))))) (defmethod object-handler-get-object ((handler tamagotchi-handler)) Modified: branches/trunk-reorg/bknr/modules/text/article-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -41,7 +41,7 @@ (progn (change-slot-values article 'subject subject 'text text) (index-article article)) (setf article (make-object 'article - :author (bknr-request-user) + :author (bknr-session-user) :subject subject :text text))) (redirect (edit-object-url article)))) @@ -104,7 +104,7 @@ (let ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) (expires (parse-date-field "expiration"))) (with-query-params (subject text layout) - (let ((snippet (make-object 'snippet :author (bknr-request-user) + (let ((snippet (make-object 'snippet :author (bknr-session-user) :subject (or subject "") :time (get-universal-time) :text text Modified: branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -19,7 +19,7 @@ ((:p :class "articleText") (:princ (article-html-text article))))) (defun list-billboards-page () - (let ((may-edit (admin-p (bknr-request-user)))) + (let ((may-edit (admin-p (bknr-session-user)))) (with-bknr-page (:title "billboards") (html ((:form :method "post" :action (request-uri)) @@ -53,7 +53,7 @@ (defun billboard-page () (let ((billboard (parse-url))) (with-query-params (new show-all delete) - (let ((may-edit (admin-p (bknr-request-user)))) + (let ((may-edit (admin-p (bknr-session-user)))) (setf billboard (find-billboard (or billboard *default-billboard*))) (if delete (let ((article (store-object-with-id delete))) @@ -62,7 +62,7 @@ (html "the article has been deleted"))) (if (and new may-edit) (let ((article (make-object 'article - :author (bknr-request-user)))) + :author (bknr-session-user)))) (billboard-add-article billboard article) (redirect (format nil "/edit-article/~a" (store-object-id article)))) (with-bknr-page (:title #?"billboard: $((billboard-name billboard))") @@ -75,7 +75,7 @@ with shown for article in (billboard-articles billboard) do (when (or show-all - (not (article-read article (bknr-request-user)))) + (not (article-read article (bknr-session-user)))) (setf shown t) (html (:tr (:td "date") @@ -106,6 +106,6 @@ (unless (billboard-always-show-all billboard) (html ((:input :type "submit" :name "show-all" :value "show-all")))) - (when (admin-p (bknr-request-user)) + (when (admin-p (bknr-session-user)) (html ((:input :type "submit" :name "new" :value "new")))))))))))) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -85,7 +85,7 @@ ()) (defmethod authorized-p ((handler edit-blog-handler)) - (let ((user (bknr-request-user)) + (let ((user (bknr-session-user)) (blog (object-handler-get-object handler))) (if blog (or (admin-p user) @@ -115,7 +115,7 @@ (index-article article))) (let ((article (make-object 'blog-article :time (get-universal-time) - :author (bknr-request-user) + :author (bknr-session-user) :subject subject :text text :keywords (list keyword)))) Modified: branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -42,7 +42,7 @@ (with-query-params (subject text lisp) (if (and subject text) (let ((paste (make-object 'paste - :author (bknr-request-user) + :author (bknr-session-user) :subject subject :time (get-universal-time) :text text @@ -59,7 +59,7 @@ (if paste (with-query-params (text lisp) (let ((annotation (make-object 'keywords-article - :author (bknr-request-user) + :author (bknr-session-user) :subject "" :time (get-universal-time) :text text Modified: branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -34,7 +34,7 @@ ()) (defmethod authorized-p ((handler edit-wiki-handler)) - (not (anonymous-p (bknr-request-user)))) + (not (anonymous-p (bknr-session-user)))) (defmethod handle-object-form ((handler edit-wiki-handler) action (article (eql nil))) @@ -53,7 +53,7 @@ (with-query-params (text comment) (let ((version (make-version (html-quote text) :comment (html-quote comment) - :author (bknr-request-user) + :author (bknr-session-user) :date (get-universal-time)))) (if article (article-add-version article version) Modified: branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -9,7 +9,7 @@ ()) (defmethod authorized-p ((handler form-handler)) - (not (equal (bknr-request-user) (find-user "anonymous")))) + (not (equal (bknr-session-user) (find-user "anonymous")))) #+(or) (defmethod handle-form ((handler submit-url-handler) action) @@ -35,12 +35,12 @@ (setf url (normalize-url url)) (ensure-form-field keywords) (if (and cache - (not (user-has-flag (bknr-request-user) :cache))) + (not (user-has-flag (bknr-session-user) :cache))) (error (make-condition 'form-not-authorized-condition :reason "You do not have the right to cache objects"))) (when cache - (make-cached-url-from-url url :user (bknr-request-user) :depth 1 + (make-cached-url-from-url url :user (bknr-session-user) :depth 1 :force nil)) (let ((url-obj (url-with-url url))) @@ -55,7 +55,7 @@ :description description :keywords keywords :date (get-universal-time) - :submitter (bknr-request-user)))) + :submitter (bknr-session-user)))) (declare (ignore submission)) (redirect (if redirect url "/url"))))) (form-field-missing-condition (e) Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -86,7 +86,7 @@ (error "no file uploaded")) (with-query-params (name keyword) (let* ((image (import-image file-pathname - :user (bknr-request-user) + :user (bknr-session-user) :keywords (list keyword) :keywords-from-dir nil)) (image-id (store-object-id image))) Modified: branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp Wed Jan 30 08:02:24 2008 @@ -35,7 +35,7 @@ (class-name (apply #'find-symbol (reverse (split "::?" (query-param "class-name")))))) (import-directory spool-dir :class-name class-name - :user (bknr-request-user) + :user (bknr-session-user) :keywords keywords :spool (import-handler-spool-dir handler) :keywords-from-dir (query-param "keyfromdir")))) 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 Wed Jan 30 08:02:24 2008 @@ -378,9 +378,7 @@ #:bknr-session-host #:host-name - #:bknr-request-user - #:bknr-request - #:bknr-request-session + #:bknr-session #:*session* #:anonymous-session Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp Wed Jan 30 08:02:24 2008 @@ -19,7 +19,6 @@ (defun session-from-request () "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter" - (start-session) (session-value 'bknr-session)) (defmethod find-user-from-request-parameters ((authorizer bknr-authorizer)) @@ -34,7 +33,6 @@ (defmethod authorize ((authorizer bknr-authorizer)) ;; Catch any errors that occur during request body processing - (start-session) (handler-case (when (session-value 'bknr-session) (return-from authorize t)) Modified: branches/trunk-reorg/bknr/web/src/web/event-log.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/event-log.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/event-log.lisp Wed Jan 30 08:02:24 2008 @@ -62,7 +62,7 @@ print-hours ;; number of hours to search print-count) ;; maximum number of events to print (when (and message (not (equal "" message))) - (make-event 'message-event :from (bknr-request-user) :text message)) + (make-event 'message-event :from (bknr-session-user) :text message)) ;; Parameter parsing, will move to with-query-params soon (if (and last-printed (not (equal "" last-printed))) (setf last-printed (parse-integer last-printed)) @@ -78,10 +78,10 @@ (let ((selected-classes (or (and show-only-class (list (find-class (find-symbol show-only-class (find-package "bknr"))))) (selected-classes (request-query)) - (mapcar #'find-class (get-user-preferences (bknr-request-user) :event-log-classes)) + (mapcar #'find-class (get-user-preferences (bknr-session-user) :event-log-classes)) (default-selected-classes)))) (unless show-only-class - (set-user-preferences (bknr-request-user) :event-log-classes (mapcar #'class-name selected-classes))) + (set-user-preferences (bknr-session-user) :event-log-classes (mapcar #'class-name selected-classes))) ;; selected-classes contains the list of event classes to print. (html ((:form :action "/event-log" :method "post") 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 Wed Jan 30 08:02:24 2008 @@ -155,8 +155,8 @@ (defmethod website-session-info ((website website)) (html ((:div :id "session-info") "local time is " (:princ-safe (format-date-time)) - (if (bknr-request-user) - (html ", logged in as " (html-link (bknr-request-user))) + (if (bknr-session-user) + (html ", logged in as " (html-link (bknr-session-user))) (html ", not logged in"))))) (defclass page-handler () @@ -216,14 +216,16 @@ (with-slots (require-user-flag) page-handler (if (and require-user-flag (not (find require-user-flag - (user-flags (bknr-request-user))))) + (user-flags (bknr-session-user))))) nil t))) (defmethod invoke-handler ((handler page-handler)) + (start-session) + (unless (session-value 'bknr-session) + (setf (session-value 'bknr-session) + (make-instance 'bknr-session :user (find-user "anonymous")))) (let* ((*website* (page-handler-site handler)) - (*session* (bknr-request-session)) - (*user* (bknr-request-user)) (*req-var-hash* (or *req-var-hash* (make-hash-table)))) (do-log-request) @@ -411,7 +413,7 @@ ()) (defmethod authorized-p ((handler admin-only-handler)) - (admin-p (bknr-request-user))) + (admin-p (bknr-session-user))) (defclass xml-handler () ((style-path :initarg :style-path :reader xml-handler-style-path)) @@ -487,7 +489,7 @@ (defgeneric import-handler-import-files (handler)) (defmethod import-handler-import-pathname ((handler import-handler)) - (let* ((user (bknr-request-user)) + (let* ((user (bknr-session-user)) (spool-dir (merge-pathnames (make-pathname :directory (list :relative (user-login user))) (import-handler-spool-dir handler)))) Modified: branches/trunk-reorg/bknr/web/src/web/sessions.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/sessions.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/sessions.lisp Wed Jan 30 08:02:24 2008 @@ -2,28 +2,26 @@ (defclass bknr-session () ((id :initarg :id :reader bknr-session-id :initform (get-universal-time)) - (user :initarg :user :reader bknr-session-user :initform nil) + (user :initarg :user) (host :initarg :host :reader bknr-session-host :initform nil))) (defmethod print-object ((session bknr-session) stream) (print-unreadable-object (session stream :type t :identity t) - (format stream "user ~A host ~A" (bknr-session-user session) (bknr-session-host session)) + (with-slots (user host) session + (format stream "user ~A host ~A" user host)) session)) -(defmethod bknr-session-user ((user (eql nil))) - nil) - -(defun bknr-request-user () - (bknr-session-user (session-value 'bknr-session))) - -(defun bknr-request-session () +(defun bknr-session () (session-value 'bknr-session)) +(defun bknr-session-user () + (slot-value (bknr-session) 'user)) + (defun do-log-request () (format *debug-io* "Log: ~A~%" (request-uri)) (return-from do-log-request) #+(or) - (let* ((session (bknr-request-session)) + (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) (url (request-uri)) @@ -45,7 +43,7 @@ (defun do-error-log-request (error) (format *debug-io* "Error: ~A~%" error) #+(or) - (let* ((session (bknr-request-session)) + (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) (url (request-uri)) Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Wed Jan 30 08:02:24 2008 @@ -226,7 +226,7 @@ do (navi-button :url link :text name))))) (when (and (website-admin-navigation *website*) - (admin-p (bknr-request-user))) + (admin-p (bknr-session-user))) (html ((:div :class "navi") "admin: " (loop Modified: branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp Wed Jan 30 08:02:24 2008 @@ -39,7 +39,7 @@ (defmethod authorized-p ((handler user-handler)) (let* ((user (object-handler-get-object handler)) - (web-user (bknr-request-user)) + (web-user (bknr-session-user)) (action (query-param "action")) (action-keyword (when action (make-keyword-from-string action)))) (cond ((anonymous-p web-user) nil) @@ -87,7 +87,7 @@ (defmethod handle-object-form ((handler user-handler) (action (eql :save)) user) (unless user - (setf user (bknr-request-user))) + (setf user (bknr-session-user))) (when user (with-query-params (password password-repeat full-name @@ -98,7 +98,7 @@ (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name))) - (when (admin-p (bknr-request-user)) + (when (admin-p (bknr-session-user)) (let* ((all-flags (all-user-flags)) (set-flags (keywords-from-query-param-list (query-param-list "flags"))) (unset-flags (set-difference all-flags set-flags))) @@ -112,7 +112,7 @@ (:report "You are not authorized to perform this operation")) (defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user) - (unless (admin-p (bknr-request-user)) + (unless (admin-p (bknr-session-user)) (error 'unauthorized-error)) (when user (delete-user user)) 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 Wed Jan 30 08:02:24 2008 @@ -75,8 +75,8 @@ (defmethod handle ((handler login-js-handler)) (format *html-stream* "parent.login_complete(~A, ~S);~%" - (if (admin-p (bknr-request-user)) "true" "false") - (user-login (bknr-request-user)))) + (if (admin-p (bknr-session-user)) "true" "false") + (user-login (bknr-session-user)))) (defclass clients-js-handler (javascript-handler page-handler) ()) Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Wed Jan 30 08:02:24 2008 @@ -2,6 +2,9 @@ (defun startup () (setq cxml::*default-catalog* '("/home/hans/share/xml/catalog")) + ;; XXX hack hack hack + (mapcar #'cl-gd::load-foreign-library + '("/usr/lib/libcrypto.so" "/usr/lib/libssl.so" "/usr/local/lib/libgd.so" "/home/hans/bknr-svn/thirdparty/cl-gd/cl-gd-glue.so")) (when *store* (close-store)) (make-instance 'store Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Wed Jan 30 08:02:24 2008 @@ -3,6 +3,13 @@ (enable-interpol-syntax) +(defclass admin-handler (admin-only-handler page-handler) + ()) + +(defmethod handle ((handler admin-handler)) + (with-bknr-page (:title "CMS") + "Please choose an administration activity from the menu above")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -23,6 +30,7 @@ ("/upload-animation" upload-animation-handler) ("/upload-button" upload-button-handler) ("/rss" rss-handler) + ("/admin" admin-handler) ("/" redirect-handler :to "/frontpage") user

1 0

[bknr-cvs] r2423 - branches/bos/projects/bos/payment-website/infosystem
by ksprotte＠common-lisp.net 30 Jan '08

30 Jan '08

Author: ksprotte Date: Wed Jan 30 06:30:27 2008 New Revision: 2423 Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js Log: added Google Earth View link to payment-website/infosystem/javascript.js Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js ============================================================================== --- branches/bos/projects/bos/payment-website/infosystem/javascript.js (original) +++ branches/bos/projects/bos/payment-website/infosystem/javascript.js Wed Jan 30 06:30:27 2008 @@ -396,6 +396,9 @@ + n_profil['anzahl'] + ' m²</td></tr><tr> <td width="60" class="PoiNavigation">' + msg('seit') + ':</td><td class="PoiNavigation">' + n_profil.contracts[0].date + + '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="10"/></td></tr>' + + '</td></tr><tr><td colspan="2" class="PoiNavigation"><a href="' + http_pfad + + '/contract-kml/' + n_profil.contracts[0].id + '">Google Earth View</a></td></tr>' + '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="20"/></td></tr>' + '<tr> <td colspan="2" class="PoiNavigation">' + n_profil['nachricht']

1 0

[bknr-cvs] r2422 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 30 Jan '08

30 Jan '08

Author: ksprotte Date: Wed Jan 30 05:58:28 2008 New Revision: 2422 Modified: branches/bos/projects/bos/web/kml-handlers.lisp Log: kml generation with utf-8 now working Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Wed Jan 30 05:58:28 2008 @@ -6,6 +6,12 @@ (defun kml-format-color (color &optional (opacity 255)) (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) +(defun utf8-text (string) + ;; cxml::utf8-string-to-rod did not + ;; what we want, so we use utf-8-string-to-bytes + ;; instead + (cxml:text (utf-8-string-to-bytes string))) + (defclass contract-kml-handler (object-handler) ()) @@ -18,10 +24,10 @@ (let ((polygon (m2s-polygon-lon-lat (contract-m2s c))) (name (user-full-name (contract-sponsor c)))) (with-element "Placemark" - (with-element "name" (text (format nil "~A ~Dm2" - (if name name "anonymous") - (length (contract-m2s c))))) - (with-element "description" (text "a description")) + (with-element "name" (utf8-text (format nil "~A ~Dm²" + (if name name "anonymous") + (length (contract-m2s c))))) + (with-element "description" (utf8-text "a description")) (with-element "Style" (attribute "id" "#region") (with-element "LineStyle" @@ -38,10 +44,10 @@ ;; the center contract (when (eq c contract) (with-element "Placemark" - (with-element "name" (text "YOUR M2s !!!")) - (with-element "description" (text (format nil "~A ~Dm2" - (if name name "anonymous") - (length (contract-m2s c))))) + (with-element "name" (utf8-text "YOUR m²s!")) + (with-element "description" (utf8-text (format nil "~A ~Dm2" + (if name name "anonymous") + (length (contract-m2s c))))) (with-element "Point" (with-element "coordinates" (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))

1 0

[bknr-cvs] r2421 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 30 Jan '08

30 Jan '08

Author: ksprotte Date: Wed Jan 30 05:50:38 2008 New Revision: 2421 Added: branches/bos/projects/bos/web/utf-8.lisp Modified: branches/bos/projects/bos/web/bos.web.asd Log: added a custom utf-8 hack providing one function: utf-8-string-to-bytes Modified: branches/bos/projects/bos/web/bos.web.asd ============================================================================== --- branches/bos/projects/bos/web/bos.web.asd (original) +++ branches/bos/projects/bos/web/bos.web.asd Wed Jan 30 05:50:38 2008 @@ -19,6 +19,7 @@ :depends-on (:bknr :bknr-modules :bos.m2 :cxml) :components ((:file "packages") + (:file "utf-8" :depends-on ("packages")) (:file "config" :depends-on ("packages")) (:file "web-macros" :depends-on ("config")) (:file "web-utils" :depends-on ("web-macros")) Added: branches/bos/projects/bos/web/utf-8.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/web/utf-8.lisp Wed Jan 30 05:50:38 2008 @@ -0,0 +1,93 @@ +(in-package :bos.web) + +;; this code is heavily inspired from trivial-utf-8 +;; it only has one API function, which was not provided +;; exactly as we need it by trivial-utf-8 + +;; API +;; utf-8-string-to-bytes STRING + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *optimize* + '(optimize (speed 3) (safety 0) (space 0) (debug 1) + (compilation-speed 0)))) + +(define-condition utf-8-decoding-error (simple-error) + ((message :initarg :message) + (byte :initarg :byte :initform nil)) + (:report (lambda (err stream) + (format stream (slot-value err 'message) + (slot-value err 'byte))))) + +(declaim (inline utf-8-group-size)) +(defun utf-8-group-size (byte) + "Determine the amount of bytes that are part of the character +starting with a given byte." + (declare (type fixnum byte) + #.*optimize*) + (cond ((zerop (logand byte #b10000000)) 1) + ((= (logand byte #b11100000) #b11000000) 2) + ((= (logand byte #b11110000) #b11100000) 3) + ((= (logand byte #b11111000) #b11110000) 4) + (t (error 'utf-8-decoding-error :byte byte + :message "Invalid byte at start of character: 0x~X")))) + +(defun utf-8-string-length (string) + "Calculate the length of the string encoded by the given bytes." + (declare (type simple-string string) + #.*optimize*) + (loop :with i = 0 + :with string-length = 0 + :with array-length = (length string) + :while (< i array-length) + :do (progn + (incf (the fixnum string-length) 1) + (incf i (utf-8-group-size (char-code (char string i))))) + :finally (return string-length))) + +(defun get-utf-8-character (string group-size &optional (start 0)) + "Given an array of bytes and the amount of bytes to use, +extract the character starting at the given start position." + (declare (type simple-string string) + (type fixnum group-size start) + #.*optimize*) + (labels ((next-byte () + (prog1 (char-code (char string start)) + (incf start))) + (six-bits (byte) + (unless (= (logand byte #b11000000) #b10000000) + (error 'utf-8-decoding-error :byte byte + :message "Invalid byte 0x~X inside a character.")) + (ldb (byte 6 0) byte))) + (case group-size + (1 (next-byte)) + (2 (logior (ash (ldb (byte 5 0) (next-byte)) 6) + (six-bits (next-byte)))) + (3 (logior (ash (ldb (byte 4 0) (next-byte)) 12) + (ash (six-bits (next-byte)) 6) + (six-bits (next-byte)))) + (4 (logior (ash (ldb (byte 3 0) (next-byte)) 18) + (ash (six-bits (next-byte)) 12) + (ash (six-bits (next-byte)) 6) + (six-bits (next-byte))))))) + +(defun utf-8-string-to-bytes (string) + (declare #.*optimize*) + (loop + with buffer = (make-array (utf-8-string-length string) + :element-type '(unsigned-byte 16)) + with string-position = 0 + with buffer-position = 0 + with string-length = (length string) + while (< string-position string-length) + do (let* ((byte (char-code (char string string-position))) + (current-group (utf-8-group-size byte))) + (when (> (+ current-group string-position) string-length) + (error 'utf-8-decoding-error + :message "Unfinished character at end of byte array.")) + (setf (aref buffer buffer-position) + (get-utf-8-character string current-group string-position)) + (incf buffer-position 1) + (incf string-position current-group)) + finally (return buffer))) +

1 0

[bknr-cvs] r2420 - in branches/trunk-reorg/bknr/web/src: . web
by hhubner＠common-lisp.net 30 Jan '08

30 Jan '08

Author: hhubner Date: Wed Jan 30 05:11:21 2008 New Revision: 2420 Modified: branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/templates.lisp Log: Add static file handling. 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 Wed Jan 30 05:11:21 2008 @@ -296,6 +296,7 @@ #:publish-handler #:unpublish + #:handler-matches #:handle-object #:handle-object-form #:handle-form 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 Wed Jan 30 05:11:21 2008 @@ -318,6 +318,15 @@ ((destination :initarg :destination :reader page-handler-destination))) +(defmethod handler-matches ((handler directory-handler)) + (and (call-next-method) + (probe-file (merge-pathnames (script-name) + (page-handler-destination handler))))) + +(defmethod handle ((handler directory-handler)) + (handle-static-file (merge-pathnames (subseq (script-name) (1+ (length (page-handler-prefix handler)))) + (page-handler-destination handler)))) + (defclass file-handler (page-handler) ((destination :initarg :destination :reader page-handler-destination) @@ -325,6 +334,9 @@ :reader page-handler-content-type)) (:default-initargs :content-type "text/plain")) +(defmethod handle ((handler file-handler)) + (handle-static-file (page-handler-destination handler))) + (defclass object-handler (prefix-handler) ((query-function :initarg :query-function :reader object-handler-query-function) (object-class :initarg :object-class :reader object-handler-object-class)) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Wed Jan 30 05:11:21 2008 @@ -292,6 +292,13 @@ (defmacro with-error-handlers ((handler) &body body) `(invoke-with-error-handlers (lambda () ,@body) ,handler)) +(defmethod handler-matches ((handler template-handler)) + (handler-case + (find-template-pathname handler (request-uri)) + (template-not-found (c) + (declare (ignore c)) + nil))) + (defmethod handle ((handler template-handler)) (with-error-handlers (handler) ;; Erst body ausfuehren...

1 0

[bknr-cvs] r2419 - in branches/trunk-reorg: bknr/web/src bknr/web/src/images bknr/web/src/web projects/quickhoney/src
by hhubner＠common-lisp.net 30 Jan '08

30 Jan '08

Author: hhubner Date: Wed Jan 30 03:46:10 2008 New Revision: 2419 Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Log: Move reference of 'modules' into website handlers definition instead of putting the module handlers at the end of the handler list. Make imageproc work, yay! Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Wed Jan 30 03:46:10 2008 @@ -34,9 +34,12 @@ (when (and (true-color-p working-image) (not (true-color-p input-image))) (true-color-to-palette :dither t :image working-image :colors-wanted 256)) - (write-image-to-stream *html-stream* (image-type-keyword image) :image working-image) + (let ((stream (send-headers))) + (setf (flex:flexi-stream-element-type stream) 'flex:octet) + (write-image-to-stream stream (image-type-keyword image) :image working-image)) (unless (eq working-image input-image) (destroy-image working-image))))) + #+(or) (unless (member type '(:jpg :jpeg)) (when (true-color-p input-image) @@ -167,8 +170,9 @@ (defmethod handle-object ((page-handler imageproc-handler) image) (format t "if-modfied-since not implemented for hunchentoot~%") - (with-http-body () - (imageproc image (cdr (decoded-handler-path page-handler)))) + (with-http-response (:content-type (image-content-type (image-type-keyword image))) + (with-http-body () + (imageproc image (cdr (decoded-handler-path page-handler))))) #+(or) (with-http-response (:content-type (image-content-type (image-type-keyword image))) (let ((ims (header-in :if-modified-since)) 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 Wed Jan 30 03:46:10 2008 @@ -301,6 +301,7 @@ #:handle-form #:object-handler-object-class #:object-handler-get-object + #:require-user-flag #:bknr-authorizer #:find-user-from-request-parameters 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 Wed Jan 30 03:46:10 2008 @@ -23,8 +23,6 @@ :accessor website-authorizer) (handler-definitions :initarg :handler-definitions :accessor website-handler-definitions) - (modules :initarg :modules - :accessor website-modules) (handlers :initform nil :accessor website-handlers) (menu :initarg :menu) (menudef-xml-file :initarg :menudef-xml-file @@ -58,7 +56,6 @@ (:default-initargs :url nil :vhosts :wild :authorizer (make-instance 'bknr-authorizer) - :modules nil :menu nil :navigation nil :admin-navigation nil @@ -124,19 +121,26 @@ (setf (choice-submenu (first choices)) (process-choices-xml (cddr choice-xml))))) (reverse choices))) +(defgeneric process-handler-definition (website definition) + (:documentation "Process a handler definition entry DEFINITION which +may either be a LIST of (PATH HANDLER-CLASS &optional INITARGS) or a +symbol, denoting a module to load at this point in the (linear) +handler definition. Every method returns a list of handler instances.") + (:method (website (definition list)) + (list (apply #'make-instance (handler-definition-class definition) + :name (handler-definition-name definition) + :site website + (handler-definition-initargs definition)))) + (:method (website (module-name symbol)) + (mapcan (curry #'process-handler-definition website) + (or (gethash (symbol-name module-name) *website-modules*) + (error "bknr module ~A not known" module-name))))) + (defmethod publish-site ((website website)) (setf (website-handlers website) - (mapcar #'(lambda (handler-definition) - (apply #'make-instance (handler-definition-class - handler-definition) - :name (handler-definition-name handler-definition) - :site website - (handler-definition-initargs handler-definition))) - (apply #'append - (website-handler-definitions website) - (mapcar #'(lambda (module-name) (or (gethash (symbol-name module-name) *website-modules*) - (error "bknr module ~A not known" module-name))) - (website-modules website))))) + (mapcan (curry #'process-handler-definition website) + (website-handler-definitions website))) + ;; XXX implicitly creating a template handler seems wrong: (when (website-template-base-directory website) (setf (slot-value website 'template-handler) (make-instance 'template-handler :name "/" @@ -145,9 +149,7 @@ :command-packages (website-template-command-packages website))) (push (website-template-handler website) (website-handlers website))) - (mapc #'(lambda (handler) - (publish-handler website handler)) - (website-handlers website)) + (mapc (curry #'publish-handler website) (website-handlers website)) (pushnew 'bknr-dispatch *dispatch-table*)) (defmethod website-session-info ((website website)) @@ -253,7 +255,7 @@ (defun bknr-dispatch (request) (declare (ignore request)) - (when-let ((handler (find-if #'handler-matches *handlers*))) + (when-let ((handler (find-if #'handler-matches (website-handlers *website*)))) (curry #'invoke-handler handler))) (defmethod publish-handler ((website website) (handler page-handler)) Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Wed Jan 30 03:46:10 2008 @@ -15,4 +15,5 @@ (bknr.cron:make-cron-job "snapshot" 'snapshot-store 0 5 :every :every)) #+cmu (actor-start (make-instance 'cron-actor)) - (publish-quickhoney)) + (publish-quickhoney) + (hunchentoot:start-server :port *webserver-port*)) Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Wed Jan 30 03:46:10 2008 @@ -6,7 +6,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun publish-quickhoney (&key (port *webserver-port*)) +(defun publish-quickhoney () (setf bknr.web::*upload-file-size-limit* (* 30 1024 1024)) (unpublish) @@ -25,16 +25,17 @@ ("/rss" rss-handler) ("/" redirect-handler :to "/frontpage") - ("/" template-handler - :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) - :command-packages ((:quickhoney . :quickhoney.tags) - (:bknr . :bknr.web))) + user + images ("/static" directory-handler :destination ,(merge-pathnames #p"static/" *website-directory*)) ("/favicon.ico" file-handler :destination ,(merge-pathnames #p"static/favicon.ico" *website-directory*) - :content-type "application/x-icon")) - :modules '(user images) + :content-type "application/x-icon") + ("/" template-handler + :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) + :command-packages ((:quickhoney . :quickhoney.tags) + (:bknr . :bknr.web)))) :admin-navigation '(("user" . "/user/") ("images" . "/edit-images") ("import" . "/import") @@ -43,6 +44,4 @@ :site-logo-url "/image/quickhoney/color,000000,33ff00" :login-logo-url "/image/quickhoney/color,000000,33ff00/double,3" :style-sheet-urls '("/static/styles.css") - :javascript-urls '("/static/javascript.js")) - - (hunchentoot:start-server :port port)) + :javascript-urls '("/static/javascript.js")))

1 0

[bknr-cvs] r2418 - in branches/bos/projects/bos: m2 web
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 07:44:49 2008 New Revision: 2418 Modified: branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/web/kml-handlers.lisp Log: the center contract is now marked with "YOUR M2s!!!" Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Tue Jan 29 07:44:49 2008 @@ -365,6 +365,16 @@ (setf (gethash (m2-contract it) contracts) t)))))) (hash-keys contracts)))) +(defun contract-center (contract) + (destructuring-bind (left top width height) + (contract-bounding-box contract) + (rect-center left top width height :roundp t))) + +(defun contract-center-lon-lat (contract) + (let ((center (contract-center contract))) + (with-points (center) + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ center-x) (- +nw-utm-y+ center-y) +utm-zone+ t)))) + (defun tx-make-contract (sponsor m2-count &key date paidp expires) (warn "Old tx-make-contract transaction used, contract dates may be wrong") (tx-do-make-contract sponsor m2-count :date date :paidp paidp :expires expires)) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Tue Jan 29 07:44:49 2008 @@ -131,6 +131,8 @@ #:contract-m2s #:contract-bounding-box #:contract-neighbours + #:contract-center + #:contract-center-lon-lat #:contract-color #:contract-cert-issued #:contract-set-paidp Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Tue Jan 29 07:44:49 2008 @@ -14,27 +14,37 @@ ;; when name is xmlns, the attribute does not show up - why (?) ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") (with-element "Document" - (dolist (contract (contract-neighbours contract)) - (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract))) - (name (user-full-name (contract-sponsor contract)))) + (dolist (c (contract-neighbours contract 50)) + (let ((polygon (m2s-polygon-lon-lat (contract-m2s c))) + (name (user-full-name (contract-sponsor c)))) (with-element "Placemark" (with-element "name" (text (format nil "~A ~Dm2" (if name name "anonymous") - (length (contract-m2s contract))))) + (length (contract-m2s c))))) (with-element "description" (text "a description")) (with-element "Style" (attribute "id" "#region") (with-element "LineStyle" (with-element "color" (text "ffff3500"))) (with-element "PolyStyle" - (with-element "color" (text (kml-format-color (contract-color contract) 175))))) + (with-element "color" (text (kml-format-color (contract-color c) 175))))) (with-element "Polygon" (with-element "styleUrl" "#region") (with-element "tessellate" (text "1")) (with-element "outerBoundaryIs" (with-element "LinearRing" (with-element "coordinates" - (text (kml-format-points polygon)))))))))))) + (text (kml-format-points polygon))))))) + ;; the center contract + (when (eq c contract) + (with-element "Placemark" + (with-element "name" (text "YOUR M2s !!!")) + (with-element "description" (text (format nil "~A ~Dm2" + (if name name "anonymous") + (length (contract-m2s c))))) + (with-element "Point" + (with-element "coordinates" + (text (kml-format-points (list (contract-center-lon-lat c))))))))))))) (defmethod handle-object ((handle-object contract-kml-handler) (object null) req) (error "Contract not found."))

1 0

[bknr-cvs] r2417 - in branches/trunk-reorg: bknr/datastore/patches bknr/datastore/src bknr/datastore/src/data bknr/datastore/src/utils bknr/datastore/src/xml bknr/datastore/src/xml-impex bknr/modules bknr/modules/album bknr/modules/bug bknr/modules/class-browser bknr/modules/comics bknr/modules/feed bknr/modules/imagemap bknr/modules/mail bknr/modules/quizz bknr/modules/stats bknr/modules/tamagotchi bknr/modules/text bknr/modules/track bknr/modules/url bknr/tools bknr/web/src bknr/web/src/images bknr/web/sr
by hhubner＠common-lisp.net 29 Jan '08

29 Jan '08

Author: hhubner Date: Tue Jan 29 07:19:19 2008 New Revision: 2417 Added: branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp - copied, changed from r2270, branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp Removed: branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd branches/trunk-reorg/bknr/datastore/src/data/object.lisp branches/trunk-reorg/bknr/datastore/src/data/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp branches/trunk-reorg/bknr/datastore/src/utils/class.lisp branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp branches/trunk-reorg/bknr/modules/album/album.lisp branches/trunk-reorg/bknr/modules/bknr-modules.asd branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp branches/trunk-reorg/bknr/modules/comics/comics.lisp branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp branches/trunk-reorg/bknr/modules/feed/feed.lisp branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mail.lisp branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp branches/trunk-reorg/bknr/modules/mail/package.lisp branches/trunk-reorg/bknr/modules/mail/register-handler.lisp branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp branches/trunk-reorg/bknr/modules/packages.lisp branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp branches/trunk-reorg/bknr/modules/stats/package.lisp branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp branches/trunk-reorg/bknr/modules/text/article-handlers.lisp branches/trunk-reorg/bknr/modules/text/article-tags.lisp branches/trunk-reorg/bknr/modules/text/article.lisp branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp branches/trunk-reorg/bknr/modules/text/package.lisp branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp branches/trunk-reorg/bknr/modules/track/import-handler.lisp branches/trunk-reorg/bknr/modules/track/track-handlers.lisp branches/trunk-reorg/bknr/modules/track/track-tags.lisp branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp branches/trunk-reorg/bknr/modules/url/url-handlers.lisp branches/trunk-reorg/bknr/tools/make-core.lisp branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image-tags.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp branches/trunk-reorg/bknr/web/src/images/session-image.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp branches/trunk-reorg/bknr/web/src/web/authorizer.lisp branches/trunk-reorg/bknr/web/src/web/event-log.lisp 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/sessions.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/bknr/web/src/web/templates.lisp branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp branches/trunk-reorg/projects/bos/m2/m2.lisp branches/trunk-reorg/projects/bos/m2/mail-generator.lisp branches/trunk-reorg/projects/bos/web/package.lisp branches/trunk-reorg/projects/bos/web/web.lisp branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp branches/trunk-reorg/projects/eboy/src/item-handlers.lisp branches/trunk-reorg/projects/eboy/src/jerks.lisp branches/trunk-reorg/projects/eboy/src/layout.lisp branches/trunk-reorg/projects/eboy/src/navi.lisp branches/trunk-reorg/projects/eboy/src/packages.lisp branches/trunk-reorg/projects/eboy/src/peecol.lisp branches/trunk-reorg/projects/gpn/add-user-handler.lisp branches/trunk-reorg/projects/gpn/gpn-tags.lisp branches/trunk-reorg/projects/gpn/import-handler.lisp branches/trunk-reorg/projects/gpn/packages.lisp branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp branches/trunk-reorg/projects/hello-web/src/handlers.lisp branches/trunk-reorg/projects/hello-web/src/packages.lisp branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp branches/trunk-reorg/projects/mah-jongg/src/game.lisp branches/trunk-reorg/projects/mah-jongg/src/package.lisp branches/trunk-reorg/projects/quickhoney/src/config.lisp branches/trunk-reorg/projects/quickhoney/src/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp branches/trunk-reorg/projects/quickhoney/src/layout.lisp branches/trunk-reorg/projects/quickhoney/src/packages.lisp branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd branches/trunk-reorg/projects/quickhoney/src/webserver.lisp branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp branches/trunk-reorg/projects/raw-data/mcp/packages.lisp branches/trunk-reorg/projects/saugnapf/src/package.lisp branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp Log: Snapshot the port of the BKNR web framework to Hunchentoot. In the process, the request argument that many of functions had has been removed. Instead, the request is accessed through the dynamic environment, which is the default mode for Hunchentoot. This commit works with SBCL and cmucl, but I am now workin with SBCL as Slime works way better there, in particular for debugging errors in hunchentoot handlers. All BKNR handlers are registered in the BKNR.WEB::*HANDLERS* special variable. BKNR registers only one dispatcher in Hunchtentoots *DISPATCHER-TABLE* that scans the BKNR handlers for a match. This is done to enhance debugability, as the *HANDLERS* table contains PAGE-HANDLER objects that carry information about their path etc. Copied: branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp (from r2270, branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp) ============================================================================== --- branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19a.lisp (original) +++ branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp Tue Jan 29 07:19:19 2008 @@ -1,5 +1,5 @@ ;;; This patch fixes the problem with get-accessor-method-function -;;; throwing an internal error in cmucl 19a. +;;; throwing an internal error in cmucl 19 ;;; ;;; Not yet in cmucl Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd (original) +++ branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd Tue Jan 29 07:19:19 2008 @@ -18,6 +18,7 @@ :depends-on (:cl-interpol :cl-ppcre :md5 + :hunchentoot ; (for hunchentoot-mp package) :iconv) :components ((:module "statistics" :components ((:file "package") Modified: branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd (original) +++ branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd Tue Jan 29 07:19:19 2008 @@ -17,5 +17,5 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cxml) :components ((:module "xml" :components ((:file "package") - (:file "xml"))))) + (:file "xml" :depends-on ("package")))))) 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 Tue Jan 29 07:19:19 2008 @@ -35,9 +35,11 @@ (defvar *suppress-schema-warnings* nil) (deftransaction update-instances-for-changed-class (class) - (unless *suppress-schema-warnings* - (warn "updating ~A instances of ~A for class changes" (length (class-instances class)) class)) - (mapc #'reinitialize-instance (class-instances class))) + (let ((instance-count (length (class-instances class)))) + (when (plusp instance-count) + (unless *suppress-schema-warnings* + (warn "updating ~A instances of ~A for class changes" instance-count class)) + (mapc #'reinitialize-instance (class-instances class))))) (defmethod instance :after ((class persistent-class) &rest args) (declare (ignore args)) Modified: branches/trunk-reorg/bknr/datastore/src/data/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/package.lisp Tue Jan 29 07:19:19 2008 @@ -4,6 +4,8 @@ (:use :cl :bknr.utils :cl-interpol :cl-ppcre :bknr.indices :bknr.statistics :closer-mop ) + #+cmu + (:shadowing-import-from :common-lisp #:subtypep #:typep) (:shadowing-import-from :cl-interpol quote-meta-chars) (:export #:*store-debug* #:*store* Modified: branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp Tue Jan 29 07:19:19 2008 @@ -18,16 +18,15 @@ (defmethod actor-start ((actor bknr-actor)) (actor-stop actor) (setf (slot-value actor 'process) - (process-run-function - (bknr-actor-name actor) - #'(lambda () - (funcall #'run-function actor))))) + (mp:make-process (lambda () + (funcall #'run-function actor)) + :name (bknr-actor-name actor)))) (defmethod actor-running-p ((actor bknr-actor)) (and (slot-boundp actor 'process) - (process-active-p (bknr-actor-process actor)))) + (mp:process-active-p (bknr-actor-process actor)))) (defmethod actor-stop ((actor bknr-actor)) (when (slot-boundp actor 'process) - (process-kill (bknr-actor-process actor)) + (mp:destroy-process (bknr-actor-process actor)) (slot-makunbound actor 'process))) Modified: branches/trunk-reorg/bknr/datastore/src/utils/class.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/class.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/class.lisp Tue Jan 29 07:19:19 2008 @@ -5,9 +5,8 @@ (defun compute-bknr-slot (class slot) (destructuring-bind (name access &rest rest) slot (let* ((initarg (make-keyword-from-string (symbol-name name))) - (package (symbol-package class)) (accessor (intern (concatenate 'string (symbol-name class) "-" - (symbol-name name)) package))) + (symbol-name name)) *package*))) (push initarg rest) (push :initarg rest) (case access Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp Tue Jan 29 07:19:19 2008 @@ -54,6 +54,7 @@ #:group-on #:find-all #:genlist + #+no-alexandria #:rotate #:nrotate #:shift-until @@ -66,6 +67,7 @@ #:incf-hash ;; randomize + #+no-alexandria #:random-elt #:random-elts #:randomize-list Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp Tue Jan 29 07:19:19 2008 @@ -283,6 +283,7 @@ do (incf-hash (funcall key object) (nth i hash-tables)))) (apply #'values sum hash-tables))) +#+no-alexandria (defun rotate (list) (when list (append (cdr list) (list (car list))))) @@ -350,6 +351,7 @@ (setf l (randomize l))))) l) +#+no-alexandria (defun random-elt (choices) (when choices (elt choices (random (length choices))))) Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp Tue Jan 29 07:19:19 2008 @@ -2,14 +2,13 @@ (defpackage :bknr.impex (:use :cl - #+clisp - :ext - :cl-user :cxml :closer-mop :bknr.utils :bknr.xml :bknr.indices) + #+cmu + (:shadowing-import-from :common-lisp #:subtypep #:typep) (:export #:xml-class #:parse-xml-file Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp Tue Jan 29 07:19:19 2008 @@ -12,8 +12,8 @@ (defmacro with-xml-export* ((&key output indentation canonical) &body body) `(let ((*objects-written* (make-hash-table :test #'equal)) (cxml::*current-element* nil) - (cxml::*sink* (cxml:make-character-stream-sink ,output - :indentation ,indentation :canonical ,canonical))) + (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output + :indentation ,indentation :canonical ,canonical))) ,@body)) (defmacro with-xml-export (nil &body body) Modified: branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp Tue Jan 29 07:19:19 2008 @@ -18,7 +18,7 @@ (error "Some children are not strings")))) (defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) + (cadr (assoc attribute-name (node-attrs xml) :test #'equal))) (defun node-child-string-body (xml node-name) (let ((child (find-child xml node-name))) Modified: branches/trunk-reorg/bknr/modules/album/album.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/album/album.lisp (original) +++ branches/trunk-reorg/bknr/modules/album/album.lisp Tue Jan 29 07:19:19 2008 @@ -32,16 +32,16 @@ (defclass album-handler (prefix-handler) ()) -(defmethod handle ((handler album-handler) req) +(defmethod handle ((handler album-handler)) (multiple-value-bind (username album) - (parse-handler-url handler req) + (parse-handler-url handler) (let ((user (when username (find-user username)))) (cond ((and user album) - (with-bknr-page (req :title #?"${username} : ${album}") + (with-bknr-page (:title #?"${username} : ${album}") (album :username username :album album))) (user - (with-bknr-page (req :title #?"${username}'s albums") + (with-bknr-page (:title #?"${username}'s albums") (user-albums :username username))) - (t (with-bknr-page (req :title "No such album") + (t (with-bknr-page (:title "No such album") (:h2 "No such album"))))))) Modified: branches/trunk-reorg/bknr/modules/bknr-modules.asd ============================================================================== --- branches/trunk-reorg/bknr/modules/bknr-modules.asd (original) +++ branches/trunk-reorg/bknr/modules/bknr-modules.asd Tue Jan 29 07:19:19 2008 @@ -17,16 +17,16 @@ :depends-on (:cl-interpol :cl-ppcre :cl-gd - :aserve - :net.post-office :md5 + :closer-mop + :cl-smtp :cxml :unit-test :bknr-utils :puri :stem - :bknr - :acl-compat) + :bknr-web + :parenscript) :components ((:file "packages") @@ -45,6 +45,7 @@ :depends-on ("package")) (:file "blog" :depends-on ("article" "vector-search")) + #+(or) (:file "billboard" :depends-on ("article")) (:file "article-tags" @@ -53,6 +54,7 @@ :depends-on ("article")) (:file "blog-handlers" :depends-on ("blog" "article-tags" "article-handlers")) + #+(or) (:file "billboard-handlers" :depends-on ("billboard" "article-tags")) (:file "article-handlers" @@ -64,6 +66,7 @@ :depends-on ("paste-tags"))) :depends-on ("packages")) + #+(or) (:module "feed" :components ((:file "feed") (:file "feed-tags" :depends-on ("feed")) @@ -130,6 +133,7 @@ :depends-on ("general" "web" "packages")) + #+(or) (:module "track" :components ((:file "track") (:file "media" :depends-on ("track")) @@ -144,5 +148,6 @@ :depends-on ("media"))) :depends-on ("packages")) + #+(or) (:module "comics" :components ((:file "comics")))) :depends-on ("packages")) Modified: branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -5,31 +5,31 @@ (defclass bug-tracker-handler (edit-object-handler) ()) -(defmethod object-handler-get-object ((hander bug-tracker-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((hander bug-tracker-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'bug-tracker)))) -(defmethod handle-object-form ((handler bug-tracker-handler) action (tracker (eql nil)) req) +(defmethod handle-object-form ((handler bug-tracker-handler) action (tracker (eql nil))) (let ((bug-trackers (all-bug-trackers))) - (with-bknr-page (req :title "Bug trackers") + (with-bknr-page (:title "Bug trackers") (:h2 "all bug-trackers") (:ul (dolist (bug-tracker bug-trackers) (html (:li ((:a :href (format nil "/bug-tracker/~a" (mailinglist-name bug-tracker))) (:princ-safe (mailinglist-name bug-tracker)))))))))) -(defmethod handle-object-form ((handler bug-tracker-handler) action tracker req) - (with-bknr-page (req :title #?"bug-tracker for $((mailinglist-name tracker))") - (when (admin-p (bknr-request-user req)) +(defmethod handle-object-form ((handler bug-tracker-handler) action tracker) + (with-bknr-page (:title #?"bug-tracker for $((mailinglist-name tracker))") + (when (admin-p (bknr-request-user)) (html ((:a :href (format nil "/edit-bug-tracker/~a" (store-object-id tracker))) "edit bug-tracker"))) (bug-tracker-page :bug-tracker-id (store-object-id tracker)))) -(defmethod file-bug-report ((handler bug-tracker-handler) tracker req) - (let ((user (bknr-request-user req))) +(defmethod file-bug-report ((handler bug-tracker-handler) tracker) + (let ((user (bknr-request-user))) ;; XXX check user rights - (with-query-params (req name status priority description) + (with-query-params (name status priority description) (let ((bug-report (make-object 'bug-report :tracker tracker :subject name @@ -41,35 +41,35 @@ bug-report)))) (defmethod handle-object-form ((handler bug-tracker-handler) (action (eql :create-bug-report)) - tracker req) - (let ((bug-report (file-bug-report handler tracker req))) - (redirect (format nil "/bug-report/~a" (store-object-id bug-report)) req))) + tracker) + (let ((bug-report (file-bug-report handler tracker))) + (redirect (format nil "/bug-report/~a" (store-object-id bug-report))))) (defclass bug-report-handler (edit-object-handler) ()) -(defmethod object-handler-get-object ((handler bug-report-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler bug-report-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'bug-report)))) -(defmethod handle-object-form ((handler bug-report-handler) action (report (eql nil)) req) - (redirect "/bug-tracker" req)) +(defmethod handle-object-form ((handler bug-report-handler) action (report (eql nil))) + (redirect "/bug-tracker")) -(defmethod handle-object-form ((handler bug-report-handler) action report req) - (with-bknr-page (req :title #?"bug-report") - (when (or (equal (bknr-request-user req) +(defmethod handle-object-form ((handler bug-report-handler) action report) + (with-bknr-page (:title #?"bug-report") + (when (or (equal (bknr-request-user) (bug-report-handler report)) - (admin-p (bknr-request-user req))) + (admin-p (bknr-request-user))) (html ((:a :href (format nil "/edit-bug-report/~a" (store-object-id report))) "edit bug-report"))) (bug-page :bug-id (store-object-id report)))) (defmethod handle-object-form ((handler bug-report-handler) (action (eql :annotate)) - report req) + report) (if report - (let ((user (bknr-request-user req))) - (with-query-params (req title text) + (let ((user (bknr-request-user))) + (with-query-params (title text) (let ((article (make-object 'article :author user :subject title @@ -77,16 +77,16 @@ (if article (bug-report-add-annotation report article) (delete-object article)) - (handle-object-form handler nil report req)))) - (handle-object-form handler nil report req))) + (handle-object-form handler nil report)))) + (handle-object-form handler nil report))) (defclass edit-bug-tracker-handler (bug-tracker-handler) ()) (defmethod handle-object-form ((handler edit-bug-tracker-handler) action - (bug-tracker (eql nil)) req) + (bug-tracker (eql nil))) (let ((bug-trackers (all-bug-trackers))) - (with-bknr-page (req :title "Bug trackers") + (with-bknr-page (:title "Bug trackers") (:h2 "all bug-trackers") (:ul (dolist (bug-tracker bug-trackers) (html (:li ((:a :href (format nil "/edit-bug-tracker/~a" @@ -96,58 +96,58 @@ (bug-tracker-form)))) (defmethod handle-object-form ((handler edit-bug-tracker-handler) - (action (eql :create)) bug-tracker req) - (with-query-params (req name email description) + (action (eql :create)) bug-tracker) + (with-query-params (name email description) (if (and name email) (let ((bug-tracker (make-object 'bug-tracker :name name :email email :description description))) - (redirect (format nil "/edit-bug-tracker/~a" (store-object-id bug-tracker)) req)) - (handle-object-form handler nil nil req)))) + (redirect (format nil "/edit-bug-tracker/~a" (store-object-id bug-tracker)))) + (handle-object-form handler nil nil)))) (defmethod handle-object-form ((handler edit-bug-tracker-handler) (action (eql :create-bug-report)) - tracker req) - (file-bug-report handler tracker req) - (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)) req)) + tracker) + (file-bug-report handler tracker) + (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)))) (defmethod handle-object-form ((handler edit-bug-tracker-handler) (action (eql :save)) - tracker req) - (if (admin-p (bknr-request-user req)) - (with-query-params (req name email description) + tracker) + (if (admin-p (bknr-request-user)) + (with-query-params (name email description) (change-slot-values tracker 'name name 'email email 'description description) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug tracker") + (with-bknr-page (:title #?"Edit bug tracker") (:p "You are not authorized to edit this bug tracker") ((:a :href "/bug-tracker") "return to bug-tracker page")))) (defmethod handle-object-form ((handler edit-bug-tracker-handler) action - bug-tracker req) - (with-bknr-page (req :title #?"Edit bug tracker: $((mailinglist-name bug-tracker))") + bug-tracker) + (with-bknr-page (:title #?"Edit bug tracker: $((mailinglist-name bug-tracker))") (bug-tracker-form :bug-tracker-id (store-object-id bug-tracker)))) (defclass edit-bug-report-handler (bug-report-handler) ()) (defmethod handle-object-form ((handler edit-bug-report-handler) - action (bug-report (eql nil)) req) - (redirect "/edit-bug-tracker" req)) + action (bug-report (eql nil))) + (redirect "/edit-bug-tracker")) (defmethod handle-object-form ((handler edit-bug-report-handler) - action bug-report req) - (with-bknr-page (req :title #?"Edit bug report") + action bug-report) + (with-bknr-page (:title #?"Edit bug report") (if bug-report (bug-form :bug-id (store-object-id bug-report)) - (redirect "/edit-bug-tracker" req)))) + (redirect "/edit-bug-tracker")))) (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :save)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) - (with-query-params (req name status priority description) + (with-query-params (name status priority description) (let ((status-kw (make-keyword-from-string status)) (priority-kw (make-keyword-from-string priority))) (if (eq status-kw :closed) @@ -163,68 +163,68 @@ 'priority priority-kw 'last-modified (get-universal-time))) (call-next-method))) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page")))) (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :close)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) (progn (change-slot-values report 'closed (get-universal-time) 'status :closed 'last-modified (get-universal-time)) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page")))) (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :reopen)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) (progn (change-slot-values report 'closed nil 'status :reopened 'last-modified (get-universal-time)) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page")))) (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :delete)) - report req) - (if (or (admin-p (bknr-request-user req)) - (equal (bknr-request-user req) + report) + (if (or (admin-p (bknr-request-user)) + (equal (bknr-request-user) (bug-report-handler report))) (progn (let ((tracker (bug-report-tracker report))) (bug-tracker-remove-bug-report tracker report) (delete-object report) - (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)) req)) - (with-bknr-page (req :title #?"Edit bug report") + (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)))) + (with-bknr-page (:title #?"Edit bug report") (:p "You are not the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page"))))) (defmethod handle-object-form ((handler edit-bug-report-handler) (action (eql :handle)) - report req) + report) (if (or (null (bug-report-handler report)) - (admin-p (bknr-request-user req))) + (admin-p (bknr-request-user))) (progn - (change-slot-values report 'handler (bknr-request-user req)) + (change-slot-values report 'handler (bknr-request-user)) (call-next-method)) - (with-bknr-page (req :title #?"Edit bug report") + (with-bknr-page (:title #?"Edit bug report") (:p "You can not become the handler of this bug report") ((:a :href (format nil "/bug-report/~a" (store-object-id report))) "return to bug-report page")))) Modified: branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp (original) +++ branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp Tue Jan 29 07:19:19 2008 @@ -4,17 +4,17 @@ ((default-package-name :initarg :default-package-name)) (:default-initargs :default-package-name nil)) -(defmethod object-handler-get-object ((handler class-browser-handler) req) +(defmethod object-handler-get-object ((handler class-browser-handler)) (destructuring-bind (class-name &optional (package-name (slot-value handler 'default-package-name))) - (mapcar #'string-upcase (reverse (split "::" (parse-url req)))) + (mapcar #'string-upcase (reverse (split "::" (parse-url)))) (find-class (find-symbol class-name (find-package package-name)) nil))) -(defmethod handle-object ((handler class-browser-handler) (class (eql nil)) req) - (user-error "Invalid class name ~A" (parse-url req))) +(defmethod handle-object ((handler class-browser-handler) (class (eql nil))) + (user-error "Invalid class name ~A" (parse-url))) -(defmethod handle-object ((handler class-browser-handler) class req) - (with-http-response (req *ent*) - (with-http-body (req *ent*) +(defmethod handle-object ((handler class-browser-handler) class) + (with-http-response () + (with-http-body () (labels ((qualified-class-name (class) (let ((class-name (class-name class))) (format nil "~A::~A" (package-name (symbol-package class-name)) (symbol-name class-name)))) @@ -26,7 +26,7 @@ (when (documentation class t) (html (:p (:princ-safe (documentation class t))))) - (dolist (subclass (pcl:class-direct-subclasses class)) + (dolist (subclass (closer-mop:class-direct-subclasses class)) (show-class subclass (1+ level))))))) (html (:head Modified: branches/trunk-reorg/bknr/modules/comics/comics.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/comics/comics.lisp (original) +++ branches/trunk-reorg/bknr/modules/comics/comics.lisp Tue Jan 29 07:19:19 2008 @@ -46,6 +46,7 @@ (concatenate 'string "http://" host image)) (t (render-uri (puri:merge-uris uri mainuri) nil))))) +#+(or) (defmethod get-comic ((comic comic) &key force) (with-slots (name url mainurl imgregexp mainregexp) comic (let* ((date (daytag)) Modified: branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/edit-feed-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,8 +5,8 @@ (defclass edit-feed-handler (edit-object-handler feed-handler) ((require-user-flag :initform :feed))) -(defmethod handle-object-form ((handler edit-feed-handler) action (feed (eql nil)) req) - (with-bknr-page (req :title "create feed") +(defmethod handle-object-form ((handler edit-feed-handler) action (feed (eql nil))) + (with-bknr-page (:title "create feed") (:h2 "Manage feeds") (:ul (loop for feed in (all-feeds) do (html (:li ((:a :href (format nil "/edit-feed/~a" @@ -15,16 +15,16 @@ (:h2 "Create feed") (feed-form))) -(defmethod handle-object-form ((handler edit-feed-handler) action feed req) +(defmethod handle-object-form ((handler edit-feed-handler) action feed) (let ((feed-name (feed-name feed))) - (with-bknr-page (req :title #?"edit feed: ${feed-name}") + (with-bknr-page (:title #?"edit feed: ${feed-name}") (:h2 #?"Edit feed: ${feed-name}") (feed-form :feed-id (store-object-id feed))))) -(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :create)) obj req) - (with-query-params (req name url refresh type encoding) +(defmethod handle-object-form ((handler edit-feed-handler) (action (eql :create)) obj) + (with-query-params (name url refresh type encoding) (if (and name url type) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) (feed (make-object 'feed :name name :url url @@ -34,38 +34,38 @@ :type (make-keyword-from-string type) :encoding (make-keyword-from-string encoding) :keywords keywords))) - (redirect (format nil "/edit-feed/~a" (feed-name feed)) req)) - (handle-object-form handler nil nil req)))) + (redirect (format nil "/edit-feed/~a" (feed-name feed)))) + (handle-object-form handler nil nil)))) (defmethod handle-object-form ((handler edit-feed-handler) (action (eql :add-keywords)) - feed req) + feed) (when feed (let ((keywords (keywords-from-query-param-list - (query-param-list req "keyword")))) + (query-param-list "keyword")))) (store-object-add-keywords feed 'keywords keywords))) (call-next-method)) (defmethod handle-object-form ((handler edit-feed-handler) (action (eql :remove-keywords)) - feed req) + feed) (when feed (let ((keywords (keywords-from-query-param-list - (query-param-list req "keyword")))) + (query-param-list "keyword")))) (store-object-remove-keywords feed 'keywords keywords))) (call-next-method)) (defmethod handle-object-form ((handler edit-feed-handler) (action (eql :update)) - feed req) + feed) (when feed (update-feed feed :force t)) (call-next-method)) (defmethod handle-object-form ((handler edit-feed-handler) (action (eql :save)) - feed req) + feed) (when feed - (with-query-params (req url refresh type encoding) + (with-query-params (url refresh type encoding) (when (and url (not (string-equal url (feed-url feed)))) (feed-change-url feed url)) (when refresh (change-slot-values feed 'refresh-interval (parse-integer refresh))) @@ -75,6 +75,6 @@ (defmethod handle-object-form ((handler edit-feed-handler) (action (eql :delete)) - feed req) + feed) (when feed (delete-object feed)) - (redirect "/edit-feed" req)) + (redirect "/edit-feed")) Modified: branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -19,18 +19,18 @@ (defclass feed-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler feed-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler feed-handler)) + (let ((id-or-name (parse-url))) (find-store-object id-or-name :class 'feed))) -(defmethod handle-object ((handler feed-handler) (feed (eql nil)) req) - (with-bknr-page (req :title #?"bknr feed aggregator: all feeds") +(defmethod handle-object ((handler feed-handler) (feed (eql nil))) + (with-bknr-page (:title #?"bknr feed aggregator: all feeds") (feed-list (all-feeds)))) -(defmethod handle-object ((handler feed-handler) feed req) +(defmethod handle-object ((handler feed-handler) feed) (let ((feed-name (feed-name feed)) (rss-feed (feed-rss-feed feed))) - (with-bknr-page (req :title #?"bknr feed aggregator: ${feed-name}") + (with-bknr-page (:title #?"bknr feed aggregator: ${feed-name}") (feed :feed-id (store-object-id feed)) (when rss-feed (rss-feed-page (rss-channel-link (rss-feed-channel rss-feed)) @@ -42,37 +42,37 @@ ()) (defmethod object-date-list-handler-grouped-objects ((handler feed-list-handler) - object req) - (let* ((title (object-list-handler-title handler object req)) - (feeds (object-list-handler-get-objects handler object req)) - (rss-feed (merge-feeds title (render-uri (request-uri req) nil) + object) + (let* ((title (object-list-handler-title handler object)) + (feeds (object-list-handler-get-objects handler object)) + (rss-feed (merge-feeds title (render-uri (request-uri) nil) title (remove nil (mapcar #'feed-rss-feed feeds)))) (grouped-items (rss-feed-group-items rss-feed))) grouped-items)) -(defmethod handle-object ((handler feed-list-handler) foo req) - (let ((title (object-list-handler-title handler foo req)) - (rss-link (object-list-handler-rss-link handler foo req)) - (grouped-items (object-date-list-handler-grouped-objects handler foo req))) - (with-bknr-page (req :title title) +(defmethod handle-object ((handler feed-list-handler) foo) + (let ((title (object-list-handler-title handler foo)) + (rss-link (object-list-handler-rss-link handler foo)) + (grouped-items (object-date-list-handler-grouped-objects handler foo))) + (with-bknr-page (:title title) (html ((:a :href rss-link) "rss") (rss-feed-page rss-link title grouped-items))))) (defclass feed-keyword-handler (feed-list-handler keyword-handler) ()) -(defmethod object-list-handler-title ((handler feed-keyword-handler) keyword req) +(defmethod object-list-handler-title ((handler feed-keyword-handler) keyword) (format nil "feeds with keyword: ~a" keyword)) -(defmethod object-list-handler-rss-link ((handler feed-keyword-handler) keyword req) +(defmethod object-list-handler-rss-link ((handler feed-keyword-handler) keyword) (format nil "/feed-keyword-rss/~a" keyword)) -(defmethod object-list-handler-get-objects ((handler feed-keyword-handler) keyword req) +(defmethod object-list-handler-get-objects ((handler feed-keyword-handler) keyword) (get-keyword-feeds keyword)) #+xxx -(defmethod handle-object ((handler feed-keyword-handler) (keyword (eql nil)) req) - (with-bknr-page (req :title "all-feed-keywords") +(defmethod handle-object ((handler feed-keyword-handler) (keyword (eql nil))) + (with-bknr-page (:title "all-feed-keywords") (:ul (loop for keyword in (index-keys (current-store) :feed-keywords-key) for name = (string-downcase (symbol-name keyword)) do (html (:li @@ -84,28 +84,28 @@ (defclass feed-union-handler (feed-list-handler keywords-handler) ()) -(defmethod object-list-handler-title ((handler feed-union-handler) keywords req) +(defmethod object-list-handler-title ((handler feed-union-handler) keywords) (format nil "feeds with keywords: ~a" keywords)) -(defmethod object-list-handler-rss-link ((handler feed-union-handler) keywords req) +(defmethod object-list-handler-rss-link ((handler feed-union-handler) keywords) (format nil "/feed-union-rss/~A" - (parse-url req))) + (parse-url))) -(defmethod object-list-handler-get-objects ((handler feed-union-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler feed-union-handler) keywords) (get-keywords-union-feeds keywords)) (defclass feed-intersection-handler (feed-list-handler keywords-handler) ()) -(defmethod object-list-handler-title ((handler feed-intersection-handler) keywords req) +(defmethod object-list-handler-title ((handler feed-intersection-handler) keywords) (format nil "feeds with all keywords: ~a" keywords)) -(defmethod object-list-handler-rss-link ((handler feed-intersection-handler) keywords req) +(defmethod object-list-handler-rss-link ((handler feed-intersection-handler) keywords) (format nil "/feed-intersection-rss/~A" - (parse-url req))) + (parse-url))) -(defmethod object-list-handler-get-objects ((handler feed-intersection-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler feed-intersection-handler) keywords) (get-keywords-intersection-feeds keywords)) @@ -114,12 +114,12 @@ (defclass rss-feed-handler (object-rss-handler feed-handler) ()) -(defmethod create-object-rss-feed ((handler rss-feed-handler) (feed (eql nil)) req) +(defmethod create-object-rss-feed ((handler rss-feed-handler) (feed (eql nil))) (make-instance 'rss-feed :channel (make-instance 'rss-channel :about "no such feed" :title "no such feed"))) -(defmethod create-object-rss-feed ((handler rss-feed-handler) feed req) +(defmethod create-object-rss-feed ((handler rss-feed-handler) feed) (if (feed-rss-feed feed) (feed-rss-feed feed) (make-instance 'rss-feed @@ -132,11 +132,11 @@ (defclass rss-feed-list-handler (object-rss-handler feed-list-handler) ()) -(defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword req) - (let ((feeds (object-list-handler-get-objects handler keyword req))) - (merge-feeds (object-list-handler-title handler keyword req) - (render-uri (request-uri req) nil) - (object-list-handler-title handler keyword req) +(defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword) + (let ((feeds (object-list-handler-get-objects handler keyword))) + (merge-feeds (object-list-handler-title handler keyword) + (render-uri (request-uri) nil) + (object-list-handler-title handler keyword) (remove nil (mapcar #'feed-rss-feed feeds))))) (defclass rss-feed-keyword-handler (rss-feed-list-handler feed-keyword-handler) Modified: branches/trunk-reorg/bknr/modules/feed/feed.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed.lisp Tue Jan 29 07:19:19 2008 @@ -56,6 +56,7 @@ (feed-article-date feed (rss-item-link item) (get-universal-time)))))))))) +#+(or) (defmethod update-feed ((feed feed) &key (force nil)) (let ((time (get-universal-time))) (if (or (> (- time (feed-last-updated feed)) 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 Tue Jan 29 07:19:19 2008 @@ -5,8 +5,8 @@ (defclass show-imagemap-handler (prefix-handler) ()) -(defmethod handle ((page-handler show-imagemap-handler) req) - (let ((map-id (parse-url req))) +(defmethod handle ((page-handler show-imagemap-handler)) + (let ((map-id (parse-url))) (let ((imagemap (find-imagemap map-id))) (with-store-image (image (imagemap-image imagemap)) (with-default-image (image) @@ -15,95 +15,95 @@ (orange (allocate-color 255 140 80))) (loop for area in (imagemap-clickable-areas imagemap) do (draw-polygon (imagemap-area-polygon area) - :color (if (equal area (session-variable :map-selected-area)) red orange) + :color (if (equal area (session-value :map-selected-area)) red orange) :filled t)) - (when (session-variable :map-points) + (when (session-value :map-points) (with-thickness (3) (with-default-color (white) - (let ((edit-points (session-variable :map-points))) + (let ((edit-points (session-value :map-points))) (case (length edit-points) (0 t) (2 (draw-filled-circle (car edit-points) (cadr edit-points) 3)) (4 (apply #'draw-line edit-points)) - (t (draw-polygon (session-variable :map-points)))))))))) - (emit-image-to-browser req image :jpg))))) + (t (draw-polygon (session-value :map-points)))))))))) + (emit-image-to-browser image :jpg))))) (defclass edit-imagemap-handler (prefix-handler) () (:default-initargs :require-user-flag :admin)) -(defmethod handle ((page-handler edit-imagemap-handler) req) +(defmethod handle ((page-handler edit-imagemap-handler)) (multiple-value-bind (map-id operation-string) - (parse-url req) - (with-bknr-page (req :title #?"imagemap editor for imagemap $(map-id)") + (parse-url) + (with-bknr-page (:title #?"imagemap editor for imagemap $(map-id)") (let ((imagemap (find-imagemap map-id :create t))) (case (make-keyword-from-string operation-string) (:add-point - (let* ((coord-string (or (caar (request-query req)) + (let* ((coord-string (or (caar (request-query)) (error "missing map coordinates"))) (point (mapcar #'parse-integer (split "," coord-string))) (clickable-area (imagemap-clickable-area-at imagemap point))) - (setf (session-variable :map-selected-area) clickable-area) + (setf (session-value :map-selected-area) clickable-area) (if clickable-area - (if (session-variable :map-points) + (if (session-value :map-points) (html (:p (:princ-safe #?"can't add point $(point) - already within another area"))) (html (:p (:princ-safe #?"area linked to $((imagemap-area-url clickable-area))") - (cmslink (self-url req :command "delete-area") + (cmslink (self-url :command "delete-area") (:princ "delete"))))) (progn - (setf (session-variable :map-points) (append point (session-variable :map-points))) + (setf (session-value :map-points) (append point (session-value :map-points))) (html (:p (:princ-safe #?"added point $(point)"))))))) (:clear-points - (setf (session-variable :map-points) nil) + (setf (session-value :map-points) nil) (html (:p "point list cleared"))) (:delete-area - (if (session-variable :map-selected-area) + (if (session-value :map-selected-area) (progn - (delete-clickable-area imagemap (session-variable :map-selected-area)) + (delete-clickable-area imagemap (session-value :map-selected-area)) (html (:p "area deleted"))) (html (:p "no area selected")))) (:make-polygon - (with-query-params (req url) - (unless (< 2 (length (session-variable :map-points))) + (with-query-params (url) + (unless (< 2 (length (session-value :map-points))) (error "select at least three points for a polygon")) (unless (and (stringp url) (not (equal "" url))) (error "enter a valid url to link the polygon to")) (add-clickable-area imagemap :url url - :polygon (session-variable :map-points)) - (setf (session-variable :map-points) nil) + :polygon (session-value :map-points)) + (setf (session-value :map-points) nil) (html (:p (:princ-safe #?"new polygon linked to $(url)"))))) (t (html (:p #?"unknown operation $(operation-string)")))) - (html ((:form :action (self-url req :command "make-polygon")) - (if (session-variable :map-points) + (html ((:form :action (self-url :command "make-polygon")) + (if (session-value :map-points) (progn (format *html-stream* "~a point~:P collected " - (/ (length (session-variable :map-points)) 2)) - (html (cmslink (self-url req :command "clear-points") + (/ (length (session-value :map-points)) 2)) + (html (cmslink (self-url :command "clear-points") (:princ "clear"))) - (when (< 4 (length (session-variable :map-points))) + (when (< 4 (length (session-value :map-points))) (html " link to url: " ((:input :type "text" :name "url" :width 40)) " " ((:input :type "submit" :value "make polygon"))))) (html "no points collected"))) - (:p ((:a :href (self-url req :command "add-point")) - ((:img :ismap "ismap" :src (self-url req :prefix "show-imagemap" :command "")))))))))) + (:p ((:a :href (self-url :command "add-point")) + ((:img :ismap "ismap" :src (self-url :prefix "show-imagemap" :command "")))))))))) (defclass imagemap-handler (prefix-handler) ()) -(defmethod handle ((page-handler imagemap-handler) req) - (let* ((map-id (parse-url req)) +(defmethod handle ((page-handler imagemap-handler)) + (let* ((map-id (parse-url)) (imagemap (find-imagemap map-id :create t)) - (coord-string (or (caar (request-query req)) + (coord-string (or (caar (request-query)) (error "missing map coordinates")))) (let* ((point (mapcar #'parse-integer (split "," coord-string))) (clickable-area (imagemap-clickable-area-at imagemap point))) (if clickable-area - (with-bknr-http-response (req :response *response-moved-permanently*) - (setf (reply-header-slot-value req :location) (imagemap-area-url clickable-area)) - (with-http-body (req *ent*))) - (with-bknr-page (req :title "inactive clickable-area") + (with-http-response (:response *response-moved-permanently*) + (setf (header-out :location) (imagemap-area-url clickable-area)) + (with-http-body ())) + (with-bknr-page (:title "inactive clickable-area") (html "the point you clicked is not within an active clickable area")))))) (define-bknr-tag imagemap-def (&key imagemap-name) 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 Tue Jan 29 07:19:19 2008 @@ -93,11 +93,11 @@ :id (regex-replace-all *message-id-re* (header :message-id) #?/\1/) - :in-reply (regex-replace-all +#| :in-reply (regex-replace-all *message-id-re* (first (if (header :in-reply-to) (split #?/\s+/ (header :in-reply-to)) - (last (split #?/\s+/ (header :references)))))) + (last (split #?/\s+/ (header :references)))))) |# :headers headers :body body))))) Modified: branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -8,19 +8,19 @@ (defclass receive-mail-handler (page-handler) ()) -(defmethod handle ((handler receive-mail-handler) req) - (with-query-params (req from to subject body) +(defmethod handle ((handler receive-mail-handler)) + (with-query-params (from to subject body) (if (and from to subject body) (let ((mail (make-object 'mail :to to :from from :subject subject :body body))) - (with-bknr-page (req :title "mail received") + (with-bknr-page (:title "mail received") (if (handle-incoming-mail mail) (html (:p "Mail was delivered successfully")) (html (:p "Mail could not be delivered"))))) - (with-bknr-page (req :title "mail could not be received") + (with-bknr-page (:title "mail could not be received") (:p "Can not receive empty mail"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,8 +30,8 @@ () (:default-initargs :object-class 'mailinglist :query-function #'mailinglist-with-name)) -(defmethod handle-object-form ((handler post-mailinglist-handler) action (mailinglist (eql nil)) req) - (with-bknr-page (req :title "Post message to mailing list") +(defmethod handle-object-form ((handler post-mailinglist-handler) action (mailinglist (eql nil))) + (with-bknr-page (:title "Post message to mailing list") (if (class-instances 'mailinglist) (html (:h1 "Select a mailinglist to post to") @@ -45,9 +45,8 @@ (defmethod handle-object-form ((handler post-mailinglist-handler) action - (mailinglist mailinglist) - req) - (with-bknr-page (req :title #?"Post message to mailing list $((mailinglist-name mailinglist))") + (mailinglist mailinglist)) + (with-bknr-page (:title #?"Post message to mailing list $((mailinglist-name mailinglist))") (html ((:form :method "POST") (:p "Subject: " ((:input :type "text" :size "50" :name "subject"))) (:p "Text" :br @@ -56,11 +55,10 @@ (defmethod handle-object-form ((handler post-mailinglist-handler) (action (eql :post)) - mailinglist - req) - (with-bknr-page (req :title #?"Posting message to mailing list $((mailinglist-name mailinglist))") + mailinglist) + (with-bknr-page (:title #?"Posting message to mailing list $((mailinglist-name mailinglist))") (html (:h2 - (with-query-params (req subject text) + (with-query-params (subject text) (cond ((not subject) (html "No subject specified")) ((not text) (html "Text missing")) @@ -75,11 +73,11 @@ (defclass unsubscribe-handler (edit-object-handler) ()) -(defmethod authorized-p ((handler unsubscribe-handler) req) +(defmethod authorized-p ((handler unsubscribe-handler)) t) -(defmethod object-handler-get-object ((handler unsubscribe-handler) req) - (subscription-with-hash (parse-url req))) +(defmethod object-handler-get-object ((handler unsubscribe-handler)) + (subscription-with-hash (parse-url))) (defun html-subscription-info (user) (if (user-subscriptions user) @@ -94,9 +92,8 @@ (defmethod handle-object-form ((handler unsubscribe-handler) action - (subscription (eql nil)) - req) - (with-bknr-page (req :title "Search subscription to remove") + (subscription (eql nil))) + (with-bknr-page (:title "Search subscription to remove") (html ((:form :method "POST") "Enter email address: " ((:input :type "text" :size "50" :name "email")) @@ -104,13 +101,12 @@ (defmethod handle-object-form ((handler unsubscribe-handler) (action (eql :search)) - (subscription (eql nil)) - req) - (with-bknr-page (req :title "Send unsubscribe information") - (with-query-params (req email) + (subscription (eql nil))) + (with-bknr-page (:title "Send unsubscribe information") + (with-query-params (email) (let ((user (find-user email))) (if user - (if (admin-p (bknr-request-user req)) + (if (admin-p (bknr-request-user)) (html-subscription-info user) (progn (html (:p "Sending unsubscribe information to " (:princ-safe (user-email user)))) @@ -120,18 +116,16 @@ (defmethod handle-object-form ((handler unsubscribe-handler) action - registration - req) - (with-bknr-page (req :title "Unsubscription confirmation") + registration) + (with-bknr-page (:title "Unsubscription confirmation") (html ((:form :method "POST") (:p "Please click the button to confirm your unsubscription request.") (submit-button "confirm" "confirm"))))) (defmethod handle-object-form ((handler unsubscribe-handler) (action (eql :confirm)) - subscription - req) - (with-bknr-page (req :title "Delete subscription") + subscription) + (with-bknr-page (:title "Delete subscription") (delete-object subscription) (html (:p "The email address " (:princ-safe (user-email (subscription-user subscription))) " is now unsubscribed from the mailing list " @@ -142,8 +136,8 @@ () (:default-initargs :object-class 'mailinglist)) -(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) (mailinglist (eql nil)) req) - (with-bknr-page (req :title "Mailinglist Maintenance") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) (mailinglist (eql nil))) + (with-bknr-page (:title "Mailinglist Maintenance") (when (class-instances 'mailinglist) (html (:h1 "Select a mailinglist to edit") @@ -159,9 +153,9 @@ (:tr (:td "Name") (:td (text-field "name")))) (submit-button "create" "create"))))) -(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :create)) (mailinglist (eql nil)) req) - (with-query-params (req email name) - (with-bknr-page (req :title "Create new mailinglist") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :create)) (mailinglist (eql nil))) + (with-query-params (email name) + (with-bknr-page (:title "Create new mailinglist") (when (or (mailinglist-with-name name) (mailinglist-with-email email)) (html @@ -173,19 +167,19 @@ (:h1 "Created mailinglist " (:princ-safe (mailinglist-name list))) (cmslink (format nil "/edit-mailinglist/~A" (store-object-id list)) "[edit]")))))) -(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) mailinglist req) - (with-bknr-page (req :title #?"Edit mailinglist $((mailinglist-name mailinglist))") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql nil)) mailinglist) + (with-bknr-page (:title #?"Edit mailinglist $((mailinglist-name mailinglist))") ((:table :border "1") (:tr (:td "Name") (:td (:princ-safe (mailinglist-name mailinglist)))) (:tr (:td "Email") (:td (:princ-safe (mailinglist-email mailinglist))))) - ((:form :action (uri-path (request-uri req)) :method "post") + ((:form :action (request-uri) :method "post") (:table (:tr (:td "Subscribe email") (:td (text-field "email")))) (submit-button "subscribe" "subscribe")))) -(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :subscribe)) mailinglist req) - (with-query-params (req email) - (with-bknr-page (req :title #?"Subscribe user $(email)") +(defmethod handle-object-form ((handler edit-mailinglist-handler) (action (eql :subscribe)) mailinglist) + (with-query-params (email) + (with-bknr-page (:title #?"Subscribe user $(email)") (let ((user (or (user-with-email (string-downcase email)) (prog1 (make-user (md5-string (format nil "~A.~A" email (get-universal-time))) Modified: branches/trunk-reorg/bknr/modules/mail/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/package.lisp Tue Jan 29 07:19:19 2008 @@ -4,14 +4,14 @@ :cxml :cl-ppcre :cl-interpol - :net.post-office + :cl-smtp :bknr.utils :bknr.web :bknr.user :bknr.indices :bknr.datastore :bknr.impex - :net.aserve + :hunchentoot :puri :xhtml-generator) (:shadowing-import-from :cl-interpol quote-meta-chars) Modified: branches/trunk-reorg/bknr/modules/mail/register-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/register-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/register-handler.lisp Tue Jan 29 07:19:19 2008 @@ -6,11 +6,11 @@ () (:default-initargs :object-class 'registration-handler :query-function #'mail-handler-with-mail)) -(defmethod authorized-p ((handler register-handler) req) +(defmethod authorized-p ((handler register-handler)) t) -(defmethod handle-object-form ((handler register-handler) action reg-handler req) - (with-bknr-page (req :title "register a user account") +(defmethod handle-object-form ((handler register-handler) action reg-handler) + (with-bknr-page (:title "register a user account") (:h2 "register a user account") ((:form :method "POST") (:table (:tr (:td "login") @@ -27,8 +27,8 @@ (submit-button "register" "register"))))))) (defmethod handle-object-form ((handler register-handler) action - (reg-handler (eql nil)) req) - (with-bknr-page (req :title "registration-handlers") + (reg-handler (eql nil))) + (with-bknr-page (:title "registration-handlers") (:ul (dolist (registration-handler (remove 'registration-handler (all-mail-handlers) @@ -44,10 +44,9 @@ ;; xxx registration-with-email and registration-with-login not defined (defmethod handle-object-form ((handler register-handler) (action (eql :register)) - reg-handler - req) - (with-query-params (req login full-name email password password2) - (with-bknr-page (req :title "Register a user account") + reg-handler) + (with-query-params (login full-name email password password2) + (with-bknr-page (:title "Register a user account") (cond ((not reg-handler) (html (:h2 "No such registration-handler"))) ((not (and login full-name email password password2)) @@ -84,17 +83,15 @@ (defmethod handle-object-form ((handler register-handler) (action (eql :unsubscribe)) - reg-handler - req) - (with-query-params (req email) - (redirect (format nil "/unsubscribe?email=~a&action=search" email) req))) + reg-handler) + (with-query-params (email) + (redirect (format nil "/unsubscribe?email=~a&action=search" email)))) (defmethod handle-object-form ((handler register-handler) (action (eql :subscribe)) - reg-handler - req) - (with-query-params (req email list) - (with-bknr-page (req :title "Create a subscription account") + reg-handler) + (with-query-params (email list) + (with-bknr-page (:title "Create a subscription account") (cond ((not reg-handler) (html (:h2 "No such registration-handler"))) ((not email) @@ -112,7 +109,7 @@ :email email :subscribe-mailinglist mailinglist)) (website-url (and mailinglist (mailinglist-website-url mailinglist)))) - (if (admin-p (bknr-request-user req)) + (if (admin-p (bknr-request-user)) (progn (confirm-registration registration) (html (:h2 "registration completed") @@ -142,17 +139,16 @@ (defclass confirm-handler (edit-object-handler) ()) -(defmethod authorized-p ((handler confirm-handler) req) +(defmethod authorized-p ((handler confirm-handler)) t) -(defmethod object-handler-get-object ((handler confirm-handler) req) - (registration-with-hash (parse-url req))) +(defmethod object-handler-get-object ((handler confirm-handler)) + (registration-with-hash (parse-url))) (defmethod handle-object-form ((handler confirm-handler) (action (eql :confirm)) - registration - req) - (with-bknr-page (req :title "Subscription confirmed") + registration) + (with-bknr-page (:title "Subscription confirmed") (if registration (handler-case (let ((mailinglist (registration-subscribe-mailinglist registration))) @@ -171,9 +167,8 @@ (defmethod handle-object-form ((handler confirm-handler) action - registration - req) - (with-bknr-page (req :title "Subscription confirmation") + registration) + (with-bknr-page (:title "Subscription confirmation") (html ((:form :method "POST") (:p "Please click the button to confirm your registration") (submit-button "confirm" "confirm"))))) Modified: branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/smtp-server.lisp Tue Jan 29 07:19:19 2008 @@ -86,7 +86,8 @@ (defun handle-smtp-client (client-socket) (handle-session (make-instance 'smtp-client :socket client-socket))) - + +#+cmu (defun smtp-server (&key (port 2525)) (let ((server-socket (socket:make-socket :connect :passive :local-port port :reuse-address t))) (unwind-protect Modified: branches/trunk-reorg/bknr/modules/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/packages.lisp (original) +++ branches/trunk-reorg/bknr/modules/packages.lisp Tue Jan 29 07:19:19 2008 @@ -4,7 +4,7 @@ :cxml :cl-ppcre :cl-interpol - :net.aserve + :hunchentoot :puri :bknr.rss :bknr.utils @@ -16,8 +16,6 @@ :bknr.impex :bknr.events :xhtml-generator - :js) + :parenscript) (:shadowing-import-from :cl-interpol quote-meta-chars) - (:shadowing-import-from :js while in create) - (:shadowing-import-from :xhtml-generator html) - (:import-from :net.html.generator *html-stream*)) + (:shadowing-import-from :parenscript while in create)) Modified: branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/quizz/edit-quizz-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -5,18 +5,17 @@ (defclass edit-quizz-handler (edit-object-handler quizz-handler) ((require-user-flag :initform :quizz))) -(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) (quizz (eql nil)) - req) - (with-bknr-page (req :title #?"edit quizz") +(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) (quizz (eql nil))) + (with-bknr-page (:title #?"edit quizz") (:ul (dolist (quizz (all-quizz)) (html (:li (html-edit-link quizz))))) (:h2 "new quizz:") (quizz-form))) -(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) quizz req) - (with-query-params (req add-question add-mc-question) +(defmethod handle-object-form ((handler edit-quizz-handler) (action (eql nil)) quizz) + (with-query-params (add-question add-mc-question) (let ((name (quizz-name quizz))) - (with-bknr-page (req :title #?"edit quizz: ${name}") + (with-bknr-page (:title #?"edit quizz: ${name}") (cond (add-question (html (html-edit-link quizz) @@ -40,73 +39,73 @@ "add a multiple choice question"))))))))) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :create)) quizz req) - (with-query-params (req name description) + (action (eql :create)) quizz) + (with-query-params (name description) (if (and name description) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) (quizz (make-object 'quizz :name name :description description :keywords keywords))) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req)))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz")))) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :save)) quizz req) + (action (eql :save)) quizz) (if quizz - (with-query-params (req description) + (with-query-params (description) (change-slot-values quizz 'description description) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz"))) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :add-keywords)) quizz req) + (action (eql :add-keywords)) quizz) (if quizz - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-add-keywords quizz 'keywords keywords) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz"))) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :remove-keywords)) quizz req) + (action (eql :remove-keywords)) quizz) (if quizz - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-remove-keywords quizz 'keywords keywords) - (redirect (edit-object-url quizz) req)) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url quizz))) + (redirect "/edit-quizz"))) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :delete)) quizz req) + (action (eql :delete)) quizz) (when quizz ;;; delete questions explicitely for now (dolist (question (quizz-questions quizz)) (delete-object question)) (delete-object quizz)) - (redirect "/edit-quizz" req)) + (redirect "/edit-quizz")) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :add-question)) quizz req) + (action (eql :add-question)) quizz) (if quizz - (with-query-params (req name question) - (let ((answers (keywords-from-query-param-list (query-param-list req "answer")))) + (with-query-params (name question) + (let ((answers (keywords-from-query-param-list (query-param-list "answer")))) (if (and name question answers) (let ((question (make-object 'question :name name :question question :answers answers :quizz quizz))) - (redirect (edit-object-url (question-quizz question)) req)) - (redirect (edit-object-url quizz) req)))) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url (question-quizz question)))) + (redirect (edit-object-url quizz))))) + (redirect "/edit-quizz"))) (defmethod handle-object-form ((handler edit-quizz-handler) - (action (eql :add-mc-question)) quizz req) + (action (eql :add-mc-question)) quizz) (if quizz - (with-query-params (req name question) - (let ((answers (keywords-from-query-param-list (query-param-list req "answer"))) + (with-query-params (name question) + (let ((answers (keywords-from-query-param-list (query-param-list "answer"))) (possible-answers (mapcar #'list (keywords-from-query-param-list - (query-param-list req "possible-keyword")) - (query-param-list req "possible-answer")))) + (query-param-list "possible-keyword")) + (query-param-list "possible-answer")))) (if (and name question answers possible-answers) (let ((question (make-object 'multiple-choice-question :name name @@ -114,22 +113,21 @@ :answers answers :possible-answers possible-answers :quizz quizz))) - (redirect (edit-object-url (question-quizz question)) req)) - (redirect (edit-object-url quizz) req)))) - (redirect "/edit-quizz" req))) + (redirect (edit-object-url (question-quizz question)))) + (redirect (edit-object-url quizz))))) + (redirect "/edit-quizz"))) (defclass edit-question-handler (edit-object-handler question-handler) ((require-user-flag :initform :quizz))) (defmethod handle-object-form ((handler edit-question-handler) (action (eql nil)) - (question (eql nil)) - req) - (redirect "/edit-quizz" req)) + (question (eql nil))) + (redirect "/edit-quizz")) (defmethod handle-object-form ((handler edit-question-handler) (action (eql nil)) - question req) + question) (let ((name (question-name question))) - (with-bknr-page (req :title #?"edit question: ${name}") + (with-bknr-page (:title #?"edit question: ${name}") (typecase question (multiple-choice-question (multiple-choice-question-form :question-id (store-object-id question))) @@ -138,21 +136,21 @@ (t (error "No such question type")))))) (defmethod handle-object-form ((handler edit-question-handler) (action (eql :delete)) - question req) + question) (let ((quizz (question-quizz question))) (when question (delete-object question)) - (redirect (edit-object-url quizz) req))) + (redirect (edit-object-url quizz)))) (defmethod handle-object-form ((handler edit-question-handler) (format-name (eql :save)) - question-obj req) + question-obj) (if question-obj - (with-query-params (req question) - (let ((answers (keywords-from-query-param-list (query-param-list req "answer"))) + (with-query-params (question) + (let ((answers (keywords-from-query-param-list (query-param-list "answer"))) (possible-answers (mapcar #'list (keywords-from-query-param-list - (query-param-list req "possible-keyword")) - (query-param-list req "possible-answer")))) + (query-param-list "possible-keyword")) + (query-param-list "possible-answer")))) (typecase question-obj (multiple-choice-question (change-slot-values question-obj 'question question @@ -162,5 +160,5 @@ (change-slot-values question-obj 'question question 'answers answers)) (t (error "Unknown question type")))) - (redirect (edit-object-url question-obj) req)) - (redirect "/edit-quizz" req))) \ No newline at end of file + (redirect (edit-object-url question-obj))) + (redirect "/edit-quizz"))) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/quizz/quizz-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -27,56 +27,56 @@ (defclass quizz-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler quizz-handler) req) - (find-store-object (parse-url req) :class 'quizz :query-function #'quizz-with-name)) +(defmethod object-handler-get-object ((handler quizz-handler)) + (find-store-object (parse-url) :class 'quizz :query-function #'quizz-with-name)) -(defmethod handle-object ((handler quizz-handler) (quizz (eql nil)) req) - (with-bknr-page (req :title #?"bknr quizz: all quizz") +(defmethod handle-object ((handler quizz-handler) (quizz (eql nil))) + (with-bknr-page (:title #?"bknr quizz: all quizz") (quizz-list (all-quizz)))) -(defmethod handle-object ((handler quizz-handler) quizz req) +(defmethod handle-object ((handler quizz-handler) quizz) (let ((quizz-name (quizz-name quizz))) - (with-bknr-page (req :title #?"bknr quizz: ${quizz-name}") + (with-bknr-page (:title #?"bknr quizz: ${quizz-name}") (quizz :quizz-id (store-object-id quizz))))) (defclass quizz-keyword-handler (keyword-handler) ()) (defmethod handle-object ((handler quizz-keyword-handler) - (keyword (eql nil)) req) - (with-bknr-page (req :title "all-quizz-keywords") + (keyword (eql nil))) + (with-bknr-page (:title "all-quizz-keywords") (:ul (dolist (keyword (all-quizz-keywords)) (html (:ul (quizz-keyword-link keyword))))))) -(defmethod handle-object ((handler quizz-keyword-handler) keyword req) - (with-bknr-page (req :title "quizz keyword: ${keyword}") +(defmethod handle-object ((handler quizz-keyword-handler) keyword) + (with-bknr-page (:title "quizz keyword: ${keyword}") (quizz-list (get-keyword-quizz keyword)))) (defclass question-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler question-handler) req) - (find-store-object (parse-url req) :class 'question :query-function #'question-with-name)) +(defmethod object-handler-get-object ((handler question-handler)) + (find-store-object (parse-url) :class 'question :query-function #'question-with-name)) (defclass quizz-take-handler (edit-object-handler quizz-handler) ()) -(defmethod authorized-p ((handler quizz-take-handler) req) +(defmethod authorized-p ((handler quizz-take-handler)) t) (defmethod handle-object-form ((handler quizz-take-handler) (action (eql nil)) - (quizz (eql nil)) req) - (with-bknr-page (req :title #?"all quizz") + (quizz (eql nil))) + (with-bknr-page (:title #?"all quizz") (:ul (dolist (quizz (all-quizz)) (html (:li ((:a :href (format nil "/quizz-take/~A" (store-object-id quizz))) (:princ-safe (quizz-name quizz))))))))) (defmethod handle-object-form ((handler quizz-take-handler) (action (eql nil)) - quizz req) + quizz) (let ((quizz-name (quizz-name quizz))) - (with-bknr-page (req :title #?"take the quizz: ${quizz-name}") + (with-bknr-page (:title #?"take the quizz: ${quizz-name}") ((:form :method "POST") (mapc #'(lambda (question) (question :question-id (store-object-id question))) @@ -85,17 +85,17 @@ (defmethod handle-object-form ((handler quizz-take-handler) (action (eql :results)) - quizz req) + quizz) (if quizz - (let* ((ids (query-param-list req "question-id")) - (answers (query-param-list req "answer")) + (let* ((ids (query-param-list "question-id")) + (answers (query-param-list "answer")) (questions (mapcar #'(lambda (id) (find-store-object id :class 'question)) ids)) (score 0) correct-answers wrong-answers (quizz-name (quizz-name quizz))) - (with-bknr-page (req :title #?"results for: ${quizz-name}") + (with-bknr-page (:title #?"results for: ${quizz-name}") (loop for question in questions for answer in answers when (answer-correct-p question answer) @@ -114,5 +114,5 @@ (:princ-safe answer) " is wrong. " (:princ-safe (format nil "~a" (question-answers question))) " would have been correct.")))))) - (redirect "/quizz-take" req))) + (redirect "/quizz-take"))) Modified: branches/trunk-reorg/bknr/modules/stats/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/package.lisp Tue Jan 29 07:19:19 2008 @@ -5,7 +5,7 @@ :cl-gd :cl-ppcre :cl-interpol - :net.aserve + :hunchentoot :puri :bknr.utils :bknr.web @@ -22,5 +22,4 @@ #:sessions-per-day-image-handler #:hits-per-day-image-handler #:hits-per-hour-image-handler) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*)) \ No newline at end of file + (:shadowing-import-from :cl-interpol #:quote-meta-chars)) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp Tue Jan 29 07:19:19 2008 @@ -13,14 +13,14 @@ (cmslink (object-url event) (:princ-safe (format nil "error in \"~a\"" (web-server-log-event-url event)))))) -(defmethod object-handler-get-object ((handler error-event-handler) req) - (let ((id (parse-handler-url handler req))) +(defmethod object-handler-get-object ((handler error-event-handler)) + (let ((id (parse-handler-url handler))) (find-store-object id :class 'web-server-error-event))) (defmethod handle-object ((handler error-event-handler) - (object (eql nil)) req) + (object (eql nil))) (let ((events (all-web-server-error-events))) - (with-bknr-page (req :title "error events") + (with-bknr-page (:title "error events") (:h1 "Error events") (:ul (dolist (event events) @@ -33,15 +33,15 @@ errorstr)))))))))) (defmethod handle-object ((handler error-event-handler) - (event web-server-error-event) req) + (event web-server-error-event)) (let ((url (web-server-log-event-url event))) - (with-bknr-page (req :title #?"Error in ${url}") + (with-bknr-page (:title #?"Error in ${url}") (:h1 #?"Error in ${url}") (with-slots (time error referer url user host backtrace) event (html (:table (:tr (:td "Date") (:td (:princ-safe (format-date-time time)))) (:tr (:td "URL") (:td (cmslink - (render-uri (merge-uris url (request-uri req)) nil) + (render-uri (merge-uris url (request-uri)) nil) (:princ-safe url)))) (:tr ((:td :colspan "2") (:princ-safe error))) (:tr ((:td :colspan "2") (:pre (:princ-safe backtrace)))))))))) @@ -49,8 +49,8 @@ (defclass stats-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler stats-handler) req) - (let* ((date (parse-handler-url handler req)) +(defmethod object-handler-get-object ((handler stats-handler)) + (let* ((date (parse-handler-url handler)) (date-components (mapcar #'(lambda (str) (parse-integer str :junk-allowed t)) (when date (split "-" date))))) (case (length date-components) @@ -63,24 +63,23 @@ (apply #'get-daily-stats date-components))) (t nil)))) -(defmethod handle-object ((handler stats-handler) (object (eql nil)) req) +(defmethod handle-object ((handler stats-handler) (object (eql nil))) (redirect (format nil "/stats/~A" (multiple-value-bind (seconds minute hour date month year) (decode-universal-time (get-universal-time)) (declare (ignore seconds minute hour date month)) - year)) - req)) + year)))) -(defmethod handle-object ((handler stats-handler) stats req) +(defmethod handle-object ((handler stats-handler) stats) (let ((type (first stats)) (date (second stats)) (web-stats (third stats))) (case type - (:year (show-year-stats (first date) web-stats req)) - (:month (show-month-stats (first date) (second date) web-stats req)) - (:day (show-day-stats (first date) (second date) (third date) web-stats req)) + (:year (show-year-stats (first date) web-stats)) + (:month (show-month-stats (first date) (second date) web-stats)) + (:day (show-day-stats (first date) (second date) (third date) web-stats)) ;; else redirect to year stats - (t (handle-object handler nil req))))) + (t (handle-object handler nil))))) (defun stats-to-html (stats) (html (:table (:tr (:td "Total hits") @@ -110,8 +109,8 @@ (html (cmslink foo (:princ-safe foo))) (html (:princ-safe foo)))))))))))) -(defun show-year-stats (year stats req) - (with-bknr-page (req :title #?"Statistics for year ${year}") +(defun show-year-stats (year stats) + (with-bknr-page (:title #?"Statistics for year ${year}") (:h2 #?"Statistics for year ${year}:") (stats-to-html stats) (:h3 "Sessions per month:") @@ -144,8 +143,8 @@ (:h3 "Sessions per User:") (stats-per-to-html (log-stats-sessions-per-user stats) "User"))) -(defun show-month-stats (month year stats req) - (with-bknr-page (req :title #?"Statistics for month ${month} / ${year}") +(defun show-month-stats (month year stats) + (with-bknr-page (:title #?"Statistics for month ${month} / ${year}") (:h2 #?"Statistics for month ${month} / ${year}:") (stats-to-html stats) (:h3 "Sessions per day:") @@ -165,8 +164,8 @@ (:h3 "Sessions per User:") (stats-per-to-html (log-stats-sessions-per-user stats) "User"))) -(defun show-day-stats (date month year stats req) - (with-bknr-page (req :title #?"Statistics for ${date} / ${month} / ${year}") +(defun show-day-stats (date month year stats) + (with-bknr-page (:title #?"Statistics for ${date} / ${month} / ${year}") (:h2 #?"Statistics for ${date} / ${month} / ${year}:") (stats-to-html stats) (:h3 "Hits per hour:") @@ -182,7 +181,7 @@ (:h3 "Sessions per User:") (stats-per-to-html (log-stats-sessions-per-user stats) "User"))) -(defun log-graph (req entries &key title (color '(0 0 255)) (column-width 50)) +(defun log-graph (entries &key title (color '(0 0 255)) (column-width 50)) (let* ((length (length entries)) (image-width (+ 20 (* length column-width))) (image-height 220) @@ -211,13 +210,13 @@ (when (> num 0) (draw-string (+ 12 (* i column-width)) (- y1 15) (format nil "~A" num) :font :small :color text))))) - (emit-image-to-browser req *default-image* :gif :date (get-universal-time))))) + (emit-image-to-browser *default-image* :gif :date (get-universal-time))))) (defclass sessions-per-month-image-handler (stats-handler) ()) -(defun make-month-log-graph (stats function req &key title) - (log-graph req (mapcar #'cons '("Jan" "Feb" "Mar" "Apr" "May" "Jun" +(defun make-month-log-graph (stats function &key title) + (log-graph (mapcar #'cons '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (mapcar #'(lambda (s) (if s (funcall function s) 0)) @@ -225,67 +224,67 @@ :title title :column-width 30)) -(defun make-day-log-graph (stats function req &key title) +(defun make-day-log-graph (stats function &key title) (let ((entries (loop for s in stats for i from 1 collect (cons (format nil "~A" i) (if s (funcall function s) 0))))) - (log-graph req entries :title title :column-width 20))) + (log-graph entries :title title :column-width 20))) -(defmethod handle-object ((handler sessions-per-month-image-handler) stats req) +(defmethod handle-object ((handler sessions-per-month-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :year) (return-from handle-object)) (let ((month-stats (nth-value 1 (apply #'make-yearly-stats date)))) - (make-month-log-graph month-stats #'log-stats-sessions req + (make-month-log-graph month-stats #'log-stats-sessions :title "Sessions per month")))) (defclass hits-per-month-image-handler (stats-handler) ()) -(defmethod handle-object ((handler hits-per-month-image-handler) stats req) +(defmethod handle-object ((handler hits-per-month-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :year) (return-from handle-object)) (let ((month-stats (nth-value 1 (apply #'make-yearly-stats date)))) - (make-month-log-graph month-stats #'log-stats-hits req + (make-month-log-graph month-stats #'log-stats-hits :title "Hits per month")))) (defclass sessions-per-day-image-handler (stats-handler) ()) -(defmethod handle-object ((handler sessions-per-day-image-handler) stats req) +(defmethod handle-object ((handler sessions-per-day-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :month) (return-from handle-object)) (let ((day-stats (nth-value 1 (apply #'make-monthly-stats date)))) - (make-day-log-graph day-stats #'log-stats-sessions req :title "Sessions per day")))) + (make-day-log-graph day-stats #'log-stats-sessions :title "Sessions per day")))) (defclass hits-per-day-image-handler (stats-handler) ()) -(defmethod handle-object ((handler hits-per-day-image-handler) stats req) +(defmethod handle-object ((handler hits-per-day-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore web-stats)) (unless (eql type :month) (return-from handle-object)) (let ((day-stats (nth-value 1 (apply #'make-monthly-stats date)))) - (make-day-log-graph day-stats #'log-stats-hits req :title "Hits per day")))) + (make-day-log-graph day-stats #'log-stats-hits :title "Hits per day")))) (defclass hits-per-hour-image-handler (stats-handler) ()) -(defmethod handle-object ((handler hits-per-hour-image-handler) stats req) +(defmethod handle-object ((handler hits-per-hour-image-handler) stats) (destructuring-bind (type date web-stats) stats (declare (ignore type date)) (let ((entries (loop with hits-per-hour = (log-stats-hits-per-hour web-stats) for hour from 0 to 23 collect (cons (format nil "~a" hour) (or (cdr (assoc hour hits-per-hour)) 0))))) - (log-graph req entries + (log-graph entries :title "Hits per hour" :column-width 30)))) Modified: branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/tamagotchi/tamagotchi-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,43 +9,41 @@ (defclass tamagotchi-handler (edit-object-handler) ()) -(defmethod authorized-p ((handler tamagotchi-handler) req) - (if (string-equal (request-method req) "GET") +(defmethod authorized-p ((handler tamagotchi-handler)) + (if (string-equal (request-method) "GET") t - (let ((tamagotchi (object-handler-get-object handler req))) + (let ((tamagotchi (object-handler-get-object handler))) (cond ((null tamagotchi) t) ((null (tamagotchi-owner tamagotchi)) t) - ((equal (bknr-request-user req) (tamagotchi-owner tamagotchi)) t) + ((equal (bknr-request-user) (tamagotchi-owner tamagotchi)) t) (t nil))))) -(defmethod object-handler-get-object ((handler tamagotchi-handler) req) - (find-store-object (parse-url req) :class 'tamagotchi :query-function #'tamagotchi-with-name)) +(defmethod object-handler-get-object ((handler tamagotchi-handler)) + (find-store-object (parse-url) :class 'tamagotchi :query-function #'tamagotchi-with-name)) (defmethod handle-object-form ((handler tamagotchi-handler) - action (tamagotchi (eql nil)) - req) - (with-bknr-page (req :title "all tamagotchis") + action (tamagotchi (eql nil))) + (with-bknr-page (:title "all tamagotchis") (:ul (dolist (tamagotchi (all-tamagotchis)) (html (:li ((:a :href (format nil "/tamagotchi/~A" (tamagotchi-name tamagotchi))) (:princ-safe (tamagotchi-name tamagotchi))))))))) (defmethod handle-object-form ((handler tamagotchi-handler) - action tamagotchi - req) + action tamagotchi) (let ((name (tamagotchi-name tamagotchi))) - (with-bknr-page (req :title #?"tamagotchi: ${name}") + (with-bknr-page (:title #?"tamagotchi: ${name}") (tamagotchi :id (store-object-id tamagotchi))))) (defmacro deftamagotchi-action (action transaction) `(defmethod handle-object-form ((handler tamagotchi-handler) (action (eql ,action)) - tamagotchi req) + tamagotchi) (when (and tamagotchi) ; (>= (- (get-universal-time) ; (tamagotchi-last-action-time tamagotchi)) 10)) (,transaction tamagotchi :time (get-universal-time))) - (redirect (object-url tamagotchi) req))) + (redirect (object-url tamagotchi)))) (deftamagotchi-action :feed tamagotchi-feed) (deftamagotchi-action :play tamagotchi-play) Modified: branches/trunk-reorg/bknr/modules/text/article-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -19,32 +19,32 @@ ;;; handlers -(defun article-page (req) - (with-bknr-page (req :title "article") - (article :id (parse-url req)))) +(defun article-page () + (with-bknr-page (:title "article") + (article :id (parse-url)))) (defclass edit-article-handler (edit-object-handler) ()) -(defmethod object-handler-get-object ((handler edit-article-handler) req) - (find-store-object (parse-url req) :class 'article)) +(defmethod object-handler-get-object ((handler edit-article-handler)) + (find-store-object (parse-url) :class 'article)) (defmethod handle-object-form ((handler edit-article-handler) - action article req) - (with-bknr-page (req :title "edit article") + action article) + (with-bknr-page (:title "edit article") (article-form :id (when article (store-object-id article))))) (defmethod handle-object-form ((handler edit-article-handler) - (action (eql :save)) article req) - (with-query-params (req subject text) + (action (eql :save)) article) + (with-query-params (subject text) (if article (progn (change-slot-values article 'subject subject 'text text) (index-article article)) (setf article (make-object 'article - :author (bknr-request-user req) + :author (bknr-request-user) :subject subject :text text))) - (redirect (edit-object-url article) req))) + (redirect (edit-object-url article)))) ;;; snippets (defmethod edit-object-url ((snippet snippet)) @@ -53,12 +53,12 @@ (defclass edit-snippet-handler (edit-object-handler) ()) -(defmethod object-handler-get-object ((handler edit-snippet-handler) req) - (find-store-object (parse-url req) :class 'snippet)) +(defmethod object-handler-get-object ((handler edit-snippet-handler)) + (find-store-object (parse-url) :class 'snippet)) (defmethod handle-object-form ((handler edit-snippet-handler) - action snippet req) - (with-bknr-page (req :title "edit snippet") + action snippet) + (with-bknr-page (:title "edit snippet") (snippet-form :id (when snippet (store-object-id snippet))) (unless snippet (html (:h2 "snippets: ") @@ -66,45 +66,45 @@ (html (:li (html-edit-link snippet))))))))) (defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :delete)) snippet req) + (action (eql :delete)) snippet) (when snippet (delete-object snippet)) - (redirect "/edit-snippet" req)) + (redirect "/edit-snippet")) (defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :remove-keywords)) snippet req) + (action (eql :remove-keywords)) snippet) (if snippet - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-remove-keywords snippet 'keywords keywords) - (redirect (edit-object-url snippet) req)) - (redirect "/edit-snippet" req))) + (redirect (edit-object-url snippet))) + (redirect "/edit-snippet"))) (defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :add-keywords)) snippet req) + (action (eql :add-keywords)) snippet) (if snippet - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (store-object-add-keywords snippet 'keywords keywords) - (redirect (edit-object-url snippet) req)) - (redirect "/edit-snippet" req))) + (redirect (edit-object-url snippet))) + (redirect "/edit-snippet"))) (defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :save)) snippet req) + (action (eql :save)) snippet) (if snippet - (with-query-params (req subject text layout) + (with-query-params (subject text layout) (unless subject (setf subject "")) - (let ((expires (parse-date-field "expiration" req))) + (let ((expires (parse-date-field "expiration"))) (change-slot-values snippet 'subject subject 'text text 'expires expires 'layout (make-keyword-from-string layout)) (index-article snippet) - (redirect (edit-object-url snippet) req))) - (redirect "/edit-snippet" req))) + (redirect (edit-object-url snippet)))) + (redirect "/edit-snippet"))) (defmethod handle-object-form ((handler edit-snippet-handler) - (action (eql :create)) snippet req) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (expires (parse-date-field "expiration" req))) - (with-query-params (req subject text layout) - (let ((snippet (make-object 'snippet :author (bknr-request-user req) + (action (eql :create)) snippet) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (expires (parse-date-field "expiration"))) + (with-query-params (subject text layout) + (let ((snippet (make-object 'snippet :author (bknr-request-user) :subject (or subject "") :time (get-universal-time) :text text @@ -112,5 +112,5 @@ :layout (make-keyword-from-string layout) :expires expires))) (if snippet - (redirect (edit-object-url snippet) req) - (redirect "/edit-snippet" req)))))) + (redirect (edit-object-url snippet)) + (redirect "/edit-snippet")))))) Modified: branches/trunk-reorg/bknr/modules/text/article-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-tags.lisp Tue Jan 29 07:19:19 2008 @@ -205,23 +205,23 @@ (when title (html (:h3 (:princ-safe title)))) ((:form :method "POST") - (text-field "search" :value (query-param *req* "search")) + (text-field "search" :value (query-param "search")) (submit-button "search" "Search!"))))) (define-bknr-tag blog-search-results () - (let* ((page (parse-integer (or (query-param *req* "page") "0"))) - (num-pages (ceiling (/ (length (session-variable :blog-search-results)) 10))) - (results (subseq (session-variable :blog-search-results) + (let* ((page (parse-integer (or (query-param "page") "0"))) + (num-pages (ceiling (/ (length (session-value :blog-search-results)) 10))) + (results (subseq (session-value :blog-search-results) (* page 10) (* (1+ page) 10)))) (when results - (html (:h3 "Results for \"" (:princ-safe (session-variable :blog-search)) "\":")) + (html (:h3 "Results for \"" (:princ-safe (session-value :blog-search)) "\":")) (dotimes (i num-pages) (html " " (if (= i page) (html (:princ-safe i)) (html ((:a :href (format nil "~A?page=~A" - (uri-path (net.aserve:request-uri *req*)) i)) + (request-uri) i)) (:princ-safe i)))) " ")) (loop for result in results Modified: branches/trunk-reorg/bknr/modules/text/article.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article.lisp Tue Jan 29 07:19:19 2008 @@ -61,6 +61,7 @@ (unless (article-read article user) (push user (article-read-by article)))) +#+(or) (defmethod article-to-rss-item ((article article) &key (url (parse-uri ""))) (let ((item-url (render-uri (puri:merge-uris (parse-uri (format nil "/article/~A" (store-object-id article))) url) nil))) Modified: branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -18,11 +18,11 @@ (html ((:p :class "articleText") (:princ (article-html-text article))))) -(defun list-billboards-page (req) - (let ((may-edit (admin-p (bknr-request-user req)))) - (with-bknr-page (req :title "billboards") +(defun list-billboards-page () + (let ((may-edit (admin-p (bknr-request-user)))) + (with-bknr-page (:title "billboards") (html - ((:form :method "post" :action (uri-path (net.aserve:request-uri req))) + ((:form :method "post" :action (request-uri)) ((:table :width "640") (:tr (:th "name") (:th "new" :br "msgs") @@ -50,22 +50,22 @@ " edit "))))))))))))) ;; xxx using old store api -(defun billboard-page (req) - (let ((billboard (parse-url req))) - (with-query-params (req new show-all delete) - (let ((may-edit (admin-p (bknr-request-user req)))) +(defun billboard-page () + (let ((billboard (parse-url))) + (with-query-params (new show-all delete) + (let ((may-edit (admin-p (bknr-request-user)))) (setf billboard (find-billboard (or billboard *default-billboard*))) (if delete (let ((article (store-object-with-id delete))) (billboard-delete-article article billboard) - (with-bknr-page (req :title "article deleted") + (with-bknr-page (:title "article deleted") (html "the article has been deleted"))) (if (and new may-edit) (let ((article (make-object 'article - :author (bknr-request-user req)))) + :author (bknr-request-user)))) (billboard-add-article billboard article) - (redirect (format nil "/edit-article/~a" (store-object-id article)) req)) - (with-bknr-page (req :title #?"billboard: $((billboard-name billboard))") + (redirect (format nil "/edit-article/~a" (store-object-id article)))) + (with-bknr-page (:title #?"billboard: $((billboard-name billboard))") (when (billboard-always-show-all billboard) (setf show-all t)) ((:form :method "post") @@ -75,7 +75,7 @@ with shown for article in (billboard-articles billboard) do (when (or show-all - (not (article-read article (bknr-request-user req)))) + (not (article-read article (bknr-request-user)))) (setf shown t) (html (:tr (:td "date") @@ -106,6 +106,6 @@ (unless (billboard-always-show-all billboard) (html ((:input :type "submit" :name "show-all" :value "show-all")))) - (when (admin-p (bknr-request-user req)) + (when (admin-p (bknr-request-user)) (html ((:input :type "submit" :name "new" :value "new")))))))))))) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -21,92 +21,92 @@ (defclass blog-handler (object-date-list-handler) ()) -(defmethod object-handler-get-object ((handler blog-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler blog-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'blog :query-function #'blog-with-name)))) -(defmethod object-list-handler-get-objects ((handler blog-handler) blog req) - (let ((date (next-day 1 :start (object-date-list-handler-date handler blog req)))) +(defmethod object-list-handler-get-objects ((handler blog-handler) blog) + (let ((date (next-day 1 :start (object-date-list-handler-date handler blog)))) (remove-if #'(lambda (article) (> (article-time article) date)) (blog-articles blog)))) -(defmethod object-date-list-handler-grouped-objects ((handler blog-handler) blog req) - (sort (group-on (object-list-handler-get-objects handler blog req) +(defmethod object-date-list-handler-grouped-objects ((handler blog-handler) blog) + (sort (group-on (object-list-handler-get-objects handler blog) :key #'(lambda (article) (get-daytime (article-time article)))) #'> :key #'car)) -(defmethod handle-object ((handler blog-handler) (blog (eql nil)) req) - (with-bknr-page (req :title "blogs") +(defmethod handle-object ((handler blog-handler) (blog (eql nil))) + (with-bknr-page (:title "blogs") (:ul (loop for blog in (sort (all-blogs) #'string< :key #'blog-name) do (html (:li (cmslink (format nil "/blog/~a" (blog-name blog)) (:princ-safe (blog-name blog))))))))) -(defmethod handle-object ((handler blog-handler) blog req) - (let ((grouped-articles (object-date-list-handler-grouped-objects handler blog req)) +(defmethod handle-object ((handler blog-handler) blog) + (let ((grouped-articles (object-date-list-handler-grouped-objects handler blog)) (name (blog-name blog))) - (with-bknr-page (req :title #?"blog: ${name}") + (with-bknr-page (:title #?"blog: ${name}") (blog-page blog grouped-articles - :start-date (object-date-list-handler-date handler blog req))))) + :start-date (object-date-list-handler-date handler blog))))) (defclass search-blog-handler (edit-object-handler blog-handler) ()) -(defmethod authorized-p ((handler search-blog-handler) req) +(defmethod authorized-p ((handler search-blog-handler)) t) (defmethod handle-object-form ((handler search-blog-handler) action - (blog (eql nil)) req) - (with-bknr-page (req :title "search blogs") + (blog (eql nil))) + (with-bknr-page (:title "search blogs") (:ul (loop for blog in (sort (all-blogs) #'string< :key #'blog-name) do (html (:li (cmslink (format nil "/search-blog/~a" (blog-name blog)) (:princ-safe (blog-name blog))))))))) (defmethod handle-object-form ((handler search-blog-handler) action - blog req) - (with-bknr-page (req :title #?"search blog $((blog-name blog))") + blog) + (with-bknr-page (:title #?"search blog $((blog-name blog))") (cmslink (format nil "/blog/~A" (blog-name blog)) "return to " (:princ-safe (blog-name blog))) (blog-search-form :title #?"search blog $((blog-name blog))") (blog-search-results))) (defmethod handle-object-form ((handler search-blog-handler) (action (eql :search)) - blog req) - (with-query-params (req search) + blog) + (with-query-params (search) (when (and blog search) - (setf (session-variable :blog-search-results) + (setf (session-value :blog-search-results) (search-blog blog search :threshold 0.01) - (session-variable :blog-search) search))) - (handle-object-form handler nil blog req)) + (session-value :blog-search) search))) + (handle-object-form handler nil blog)) (defclass edit-blog-handler (edit-object-handler blog-handler) ()) -(defmethod authorized-p ((handler edit-blog-handler) req) - (let ((user (bknr-request-user req)) - (blog (object-handler-get-object handler req))) +(defmethod authorized-p ((handler edit-blog-handler)) + (let ((user (bknr-request-user)) + (blog (object-handler-get-object handler))) (if blog (or (admin-p user) (member user (blog-owners blog))) t))) -(defmethod handle-object-form ((handler edit-blog-handler) action (blog (eql nil)) req) - (with-bknr-page (req :title "edit blogs") +(defmethod handle-object-form ((handler edit-blog-handler) action (blog (eql nil))) + (with-bknr-page (:title "edit blogs") (:ul (loop for blog in (sort (all-blogs) #'string< :key #'blog-name) do (html (:li (html-edit-link blog))))))) -(defmethod handle-object-form ((handler edit-blog-handler) action blog req) - (with-bknr-page (req :title "new blog article") +(defmethod handle-object-form ((handler edit-blog-handler) action blog) + (with-bknr-page (:title "new blog article") (:h2 "New article") (article-form) (:h2 "Old articles") (:ul (loop for article in (sort (copy-list (blog-articles blog)) #'> :key #'article-time) do (html (:li (html-edit-link article))))))) -(defmethod handle-object-form ((handler edit-blog-handler) (action (eql :save)) blog req) - (with-query-params (req article-id subject text keyword) +(defmethod handle-object-form ((handler edit-blog-handler) (action (eql :save)) blog) + (with-query-params (article-id subject text keyword) (if article-id (let ((article (find-store-object article-id :class 'blog-article))) (when article @@ -115,10 +115,10 @@ (index-article article))) (let ((article (make-object 'blog-article :time (get-universal-time) - :author (bknr-request-user req) + :author (bknr-request-user) :subject subject :text text :keywords (list keyword)))) (blog-add-article blog article))) - (handle-form handler t req))) + (handle-form handler t))) Modified: branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/htmlize-handler.lisp Tue Jan 29 07:19:19 2008 @@ -8,8 +8,8 @@ (source-types :initarg :source-types :reader htmlize-handler-source-types :initform '("lisp" "asd" "asdf" "cl"))))) -(defmethod object-handler-get-object ((handler htmlize-handler) req) - (let* ((url-path (bknr-url-path handler req)) +(defmethod object-handler-get-object ((handler htmlize-handler)) + (let* ((url-path (bknr-url-path handler)) (source-path (htmlize-handler-source-dir handler)) (path (probe-file (merge-pathnames (if (and (> (length url-path) 0) (eql (char url-path 0) #\/)) @@ -26,13 +26,13 @@ :name (pathname-name filepath) :type (pathname-type filepath)))) -(defmethod handle-object ((handler object-handler) path req) +(defmethod handle-object ((handler object-handler) path) (unless path (error "no path to generic object handler given, missing specialization?")) (if (pathname-name path) - (with-bknr-page (req :title (pathname-name path)) + (with-bknr-page (:title (pathname-name path)) (htmlize-file path *html-stream*)) - (with-bknr-page (req :title #?"Source directory: $((namestring path))") + (with-bknr-page (:title #?"Source directory: $((namestring path))") (:ul (dolist (file (directory path)) (let ((file-path (relative-link-to-file handler file))) (when (or (not (pathname-name file-path)) Modified: branches/trunk-reorg/bknr/modules/text/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/package.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/package.lisp Tue Jan 29 07:19:19 2008 @@ -4,6 +4,7 @@ :cxml :cl-ppcre :cl-interpol + :hunchentoot :puri :bknr.rss :bknr.utils @@ -63,5 +64,4 @@ #:version-text #:version-author #:version-date - #:version-comment) - (:import-from :net.html.generator #:*html-stream*)) \ No newline at end of file + #:version-comment)) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -13,15 +13,15 @@ (defclass paste-handler (edit-object-handler) ()) -(defmethod authorized-p ((handler paste-handler) req) +(defmethod authorized-p ((handler paste-handler)) t) -(defmethod object-handler-get-object ((handler paste-handler) req) - (find-store-object (parse-url req) :class 'annotated-article)) +(defmethod object-handler-get-object ((handler paste-handler)) + (find-store-object (parse-url) :class 'annotated-article)) (defmethod handle-object-form ((handler paste-handler) - action (foo (eql nil)) req) - (with-bknr-page (req :title "paste") + action (foo (eql nil))) + (with-bknr-page (:title "paste") (:h2 "new paste:") (paste-form) (:h2 "old pastes:") @@ -29,43 +29,43 @@ (html (:li (html-edit-link paste))))))) (defmethod handle-object-form ((handler paste-handler) - action paste req) + action paste) (let ((subject (article-subject paste))) - (with-bknr-page (req :title #?"paste: ${subject}") + (with-bknr-page (:title #?"paste: ${subject}") (paste paste) (:h2 "annotate:") (paste-annotate-form)))) (defmethod handle-object-form ((handler paste-handler) (action (eql :create)) - foo req) - (with-query-params (req subject text lisp) + foo) + (with-query-params (subject text lisp) (if (and subject text) (let ((paste (make-object 'paste - :author (bknr-request-user req) + :author (bknr-request-user) :subject subject :time (get-universal-time) :text text :keywords (when lisp '(:lisp)) :expires (get-universal-time)))) (if paste - (redirect (edit-object-url paste) req) - (redirect "/paste" req))) - (redirect "/paste" req)))) + (redirect (edit-object-url paste)) + (redirect "/paste"))) + (redirect "/paste")))) (defmethod handle-object-form ((handler paste-handler) (action (eql :annotate)) - paste req) + paste) (if paste - (with-query-params (req text lisp) + (with-query-params (text lisp) (let ((annotation (make-object 'keywords-article - :author (bknr-request-user req) + :author (bknr-request-user) :subject "" :time (get-universal-time) :text text :keywords (when lisp '(:lisp))))) (if annotation (annotate-article paste annotation)) - (redirect (edit-object-url paste) req))) - (redirect "/paste" req))) + (redirect (edit-object-url paste)))) + (redirect "/paste"))) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -15,53 +15,53 @@ () (:default-initargs :object-class 'wiki-article :query-function #'wiki-article-with-keyword)) -(defmethod handle-object ((handler wiki-handler) (article (eql nil)) req) - (let ((keyword (parse-url req))) +(defmethod handle-object ((handler wiki-handler) (article (eql nil))) + (let ((keyword (parse-url))) (if (null keyword) - (with-bknr-page (req :title "all wiki keywords") + (with-bknr-page (:title "all wiki keywords") (:ul (dolist (keyword (sort (wiki-keywords) #'string<)) (html (:li ((:a :href (wiki-keyword-url keyword)) (:princ-safe keyword))))))) (redirect (concatenate 'string "/edit-wiki" "/" - (parse-url req)) req)))) + (parse-url)))))) -(defmethod handle-object ((handler wiki-handler) article req) +(defmethod handle-object ((handler wiki-handler) article) (let ((keyword (wiki-article-keyword article))) - (with-bknr-page (req :title #?"wiki article: ${keyword}") + (with-bknr-page (:title #?"wiki article: ${keyword}") (wiki-article :id (store-object-id article))))) (defclass edit-wiki-handler (edit-object-handler wiki-handler) ()) -(defmethod authorized-p ((handler edit-wiki-handler) req) - (not (anonymous-p (bknr-request-user req)))) +(defmethod authorized-p ((handler edit-wiki-handler)) + (not (anonymous-p (bknr-request-user)))) (defmethod handle-object-form ((handler edit-wiki-handler) - action (article (eql nil)) req) - (with-bknr-page (req :title "edit new wiki article") - (wiki-article-form :keyword (parse-url req)))) + action (article (eql nil))) + (with-bknr-page (:title "edit new wiki article") + (wiki-article-form :keyword (parse-url)))) (defmethod handle-object-form ((handler edit-wiki-handler) - action article req) + action article) (let ((keyword (wiki-article-keyword article))) - (with-bknr-page (req :title #?"edit wiki article blorg: ${keyword}") + (with-bknr-page (:title #?"edit wiki article blorg: ${keyword}") (:p (html-edit-link article)) (wiki-article-form :id (store-object-id article))))) (defmethod handle-object-form ((handler edit-wiki-handler) - (action (eql :save)) article req) - (with-query-params (req text comment) + (action (eql :save)) article) + (with-query-params (text comment) (let ((version (make-version (html-quote text) :comment (html-quote comment) - :author (bknr-request-user req) + :author (bknr-request-user) :date (get-universal-time)))) (if article (article-add-version article version) (setf article (make-object 'wiki-article - :subject (parse-url req) - :keyword (parse-url req) + :subject (parse-url) + :keyword (parse-url) :versions (list version)))) - (redirect (object-url article) req)))) + (redirect (object-url article))))) (define-bknr-webserver-module wiki ("/wiki" wiki-handler) Modified: branches/trunk-reorg/bknr/modules/track/import-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/track/import-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/track/import-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,15 +5,15 @@ (defclass mp3-import-handler (import-handler) ()) -(defmethod import-handler-spool-files ((handler mp3-import-handler) req) - (directory (merge-pathnames "**/*.mp3" (import-handler-import-pathname handler req)))) +(defmethod import-handler-spool-files ((handler mp3-import-handler)) + (directory (merge-pathnames "**/*.mp3" (import-handler-import-pathname handler)))) -(defmethod authorized-p ((handler mp3-import-handler) req) +(defmethod authorized-p ((handler mp3-import-handler)) (or (admin-p *user*) (user-has-flag *user* :music))) -(defmethod handle-form ((handler mp3-import-handler) action req) - (with-bknr-page (req :title #?"mp3 import directory") +(defmethod handle-form ((handler mp3-import-handler) action) + (with-bknr-page (:title #?"mp3 import directory") ((:form :method "post") ((:div :class "keyword-choose" :align "center") (:h2 "Choose tags for the imported mp3s (nothing will read them from the ID3 tags):") @@ -33,32 +33,32 @@ (:div (submit-button "import" "Import")))) ((:div :class "import-list") (:h2 "Mp3s present in import spool:") - (loop for file in (import-handler-spool-files handler req) + (loop for file in (import-handler-spool-files handler) do (html (:princ-safe (namestring file)) (:br)))))) -(defmethod import-handler-import-files ((handler mp3-import-handler) req) - (let ((genre (keywords-from-query-param-list (query-param-list req "genre")))) - (with-query-params (req artist album tagsfromdir) +(defmethod import-handler-import-files ((handler mp3-import-handler)) + (let ((genre (keywords-from-query-param-list (query-param-list "genre")))) + (with-query-params (artist album tagsfromdir) (let ((tags-from-dir (case tagsfromdir (:genre-artist-album '(:genre :artist :album)) (:artist-album '(:artist :album)) (:artist '(:artist)) (t nil))) - (spool-dir (import-handler-import-pathname handler req))) + (spool-dir (import-handler-import-pathname handler))) (import-mp3-directory :spool spool-dir :genre genre :album album :artist artist :tags-from-dir tags-from-dir))))) -(defmethod handle-form ((handler mp3-import-handler) (action (eql :import)) req) - (let* ((import-log (import-handler-import-files handler req)) +(defmethod handle-form ((handler mp3-import-handler) (action (eql :import))) + (let* ((import-log (import-handler-import-files handler)) (successful-tracks (remove-if-not #'(lambda (element) (typep element 'track)) import-log :key #'cdr)) (error-log (remove-if-not #'(lambda (element) (typep element 'error)) import-log :key #'cdr))) - (with-bknr-page (req :title #?"bknr import log") + (with-bknr-page (:title #?"bknr import log") ((:div :class "error-log") (:h2 "Errors during import:") (loop for (file . error) in error-log do (typecase error Modified: branches/trunk-reorg/bknr/modules/track/track-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/track/track-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/track/track-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -21,11 +21,11 @@ (defclass track-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler track-handler) req) - (find-store-object (parse-url req) :class 'track)) +(defmethod object-handler-get-object ((handler track-handler)) + (find-store-object (parse-url) :class 'track)) -(defmethod handle-object ((handler track-handler) (track (eql nil)) req) - (with-bknr-page (req :title #?"bknr tracks") +(defmethod handle-object ((handler track-handler) (track (eql nil))) + (with-bknr-page (:title #?"bknr tracks") (:h2 "Artists: ") (:ul (dolist (artist (all-track-artists)) (html (:li (artist-html-link artist))))) @@ -33,84 +33,84 @@ (:ul (dolist (genre (all-track-genres)) (html (:li (genre-html-link genre))))))) -(defmethod handle-object ((handler track-handler) track req) +(defmethod handle-object ((handler track-handler) track) (let ((name (track-name track))) - (with-bknr-page (req :title #?"track: ${name}") + (with-bknr-page (:title #?"track: ${name}") (track :id (store-object-id track))))) (defclass edit-track-handler (edit-object-handler track-handler) ()) -(defmethod authorized-p ((handler edit-track-handler) req) +(defmethod authorized-p ((handler edit-track-handler)) (or (admin-p *user*) (user-has-flag *user* :music))) (defmethod handle-object-form ((handler edit-track-handler) action - (track (eql nil)) req) - (redirect "/edit-tracks" req)) + (track (eql nil))) + (redirect "/edit-tracks")) (defmethod handle-object-form ((handler edit-track-handler) action - track req) + track) (let ((name (track-name track))) - (with-bknr-page (req :title #?"edit track: ${name}") + (with-bknr-page (:title #?"edit track: ${name}") (track-form :id (store-object-id track))))) (defmethod handle-object-form ((handler edit-track-handler) (action (eql :save)) - track req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) - (with-query-params (req name artist album) + track) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) + (with-query-params (name artist album) (when artist (track-set-artist track artist)) (when album (track-set-album track album)) (when name (change-slot-values track 'name name)) (when genres (track-set-genres track genres)) - (redirect (edit-object-url track) req)))) + (redirect (edit-object-url track))))) (defmethod handle-object-form ((handler edit-track-handler) (action (eql :delete)) - track req) + track) (when track (delete-object track)) - (redirect "/edit-track" req)) + (redirect "/edit-track")) (defclass tracks-handler (object-list-handler) ()) -(defmethod handle-object ((handler tracks-handler) object req) - (let ((tracks (object-list-handler-get-objects handler object req)) - (title (object-list-handler-title handler object req))) - (with-bknr-page (req :title title) +(defmethod handle-object ((handler tracks-handler) object) + (let ((tracks (object-list-handler-get-objects handler object)) + (title (object-list-handler-title handler object))) + (with-bknr-page (:title title) (:ul (dolist (track tracks) (html (:li (html-link track)))))))) (defclass artist-tracks-handler (tracks-handler) ()) -(defmethod object-list-handler-get-objects ((handler artist-tracks-handler) object req) - (let ((name (parse-url req))) +(defmethod object-list-handler-get-objects ((handler artist-tracks-handler) object) + (let ((name (parse-url))) (get-artist-tracks name))) -(defmethod object-list-handler-title ((handler artist-tracks-handler) object req) - (format nil "tracks of ~a" (parse-url req))) +(defmethod object-list-handler-title ((handler artist-tracks-handler) object) + (format nil "tracks of ~a" (parse-url))) (defclass genre-tracks-handler (keyword-handler tracks-handler) ()) -(defmethod object-list-handler-get-objects ((handler genre-tracks-handler) genre req) +(defmethod object-list-handler-get-objects ((handler genre-tracks-handler) genre) (get-genre-tracks genre)) -(defmethod object-list-handler-title ((handler genre-tracks-handler) genre req) +(defmethod object-list-handler-title ((handler genre-tracks-handler) genre) (format nil "tracks of genre ~a" genre)) (defclass search-tracks-handler (edit-object-handler tracks-handler) ()) -(defmethod authorized-p ((handler search-tracks-handler) req) +(defmethod authorized-p ((handler search-tracks-handler)) t) -(defmethod object-list-handler-get-objects ((handler search-tracks-handler) object req) - (session-variable :current-track-result)) +(defmethod object-list-handler-get-objects ((handler search-tracks-handler) object) + (session-value :current-track-result)) -(defmethod search-tracks ((handler search-tracks-handler) req) - (with-query-params (req artist album name genre operator) +(defmethod search-tracks ((handler search-tracks-handler)) + (with-query-params (artist album name genre operator) (let ((artists (when artist (find-matching-strings artist (all-track-artists)))) (genre (when genre (make-keyword-from-string genre))) (albums (when album (find-matching-strings album (all-albums)))) @@ -131,17 +131,17 @@ (push name-tracks tracks)) (when genre (push (get-genre-tracks genre) tracks)) - (setf (session-variable :current-track-result) (reduce merge-op tracks))))) + (setf (session-value :current-track-result) (reduce merge-op tracks))))) (defmethod handle-object-form ((handler search-tracks-handler) - (action (eql :search)) object req) - (search-tracks handler req) + (action (eql :search)) object) + (search-tracks handler) (call-next-method)) (defmethod handle-object-form ((handler search-tracks-handler) - action object req) - (let ((tracks (object-list-handler-get-objects handler object req))) - (with-bknr-page (req :title "search tracks") + action object) + (let ((tracks (object-list-handler-get-objects handler object))) + (with-bknr-page (:title "search tracks") (search-track) (:ul (dolist (track tracks) (html (:li (html-link track)))))))) @@ -149,49 +149,49 @@ (defclass edit-tracks-handler (search-tracks-handler) ()) -(defmethod object-handler-get-object ((handler edit-tracks-handler) req) +(defmethod object-handler-get-object ((handler edit-tracks-handler)) (remove nil (mapcar #'(lambda (id) (find-store-object id :class 'track)) - (query-param-list req "track-id")))) + (query-param-list "track-id")))) (defmethod handle-object-form ((handler edit-tracks-handler) action - (tracks (eql nil)) req) - (with-bknr-page (req :title "edit tracks") + (tracks (eql nil))) + (with-bknr-page (:title "edit tracks") (search-track :title "search tracks to edit") (edit-track-collection))) (defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :search)) - tracks req) - (search-tracks handler req) + tracks) + (search-tracks handler) (call-next-method)) (defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :add-genres)) - tracks req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) + tracks) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) (dolist (track tracks) (store-object-add-keywords track 'genre genres)) - (redirect "/edit-tracks" req))) + (redirect "/edit-tracks"))) (defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :remove-genres)) - tracks req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) + tracks) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) (dolist (track tracks) (store-object-remove-keywords track 'genre genres)) - (redirect "/edit-tracks" req))) + (redirect "/edit-tracks"))) (defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :save-all)) - tracks req) - (let ((genres (keywords-from-query-param-list (query-param-list req "genre")))) - (with-query-params (req name artist album) + tracks) + (let ((genres (keywords-from-query-param-list (query-param-list "genre")))) + (with-query-params (name artist album) (when artist (mapc #'(lambda (track) (track-set-artist track artist)) tracks)) (when album (mapc #'(lambda (track) (track-set-album track album)) tracks)) (when name (mapc #'(lambda (track) (change-slot-values track 'name name)) tracks)) (when genres (mapc #'(lambda (track) (track-set-genres track genres)) tracks)) - (redirect "/edit-tracks" req)))) + (redirect "/edit-tracks")))) (defmethod handle-object-form ((handler edit-tracks-handler) (action (eql :delete-all)) - tracks req) + tracks) (mapc #'delete-object tracks) - (redirect "/edit-tracks" req)) + (redirect "/edit-tracks")) (defclass playlist-handler (object-handler) ()) @@ -202,17 +202,17 @@ (defmethod html-link ((playlist playlist)) (html ((:a :href (edit-object-url playlist)) (:princ-safe playlist)))) -(defmethod object-handler-get-object ((handler playlist-handler) req) - (find-store-object (parse-url req) :class 'playlist)) +(defmethod object-handler-get-object ((handler playlist-handler)) + (find-store-object (parse-url) :class 'playlist)) -(defmethod handle-object ((handler playlist-handler) (playlist (eql nil)) req) - (with-bknr-page (req :title #?"bknr playlists") +(defmethod handle-object ((handler playlist-handler) (playlist (eql nil))) + (with-bknr-page (:title #?"bknr playlists") (:ul (dolist (playlist (all-playlists)) (html (:li (html-link playlist))))))) -(defmethod handle-object ((handler playlist-handler) playlist req) +(defmethod handle-object ((handler playlist-handler) playlist) (let ((name (playlist-name playlist))) - (with-bknr-page (req :title #?"playlist: ${name}") + (with-bknr-page (:title #?"playlist: ${name}") (:ul (dolist (track (playlist-tracks playlist)) (html (:li (html-link track)))))))) Modified: branches/trunk-reorg/bknr/modules/track/track-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/track/track-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/track/track-tags.lisp Tue Jan 29 07:19:19 2008 @@ -60,7 +60,7 @@ (define-bknr-tag search-track (&key title) (declare (ignore title)) - (with-query-params (*req* name artist album genre) + (with-query-params (name artist album genre) (let ((genre (when genre (make-keyword-from-string genre)))) (html ((:form :method "POST") ((:table :class "search-panel") @@ -73,7 +73,7 @@ (submit-button "search" "search"))))))))) (define-bknr-tag edit-track-collection (&key title - (tracks (session-variable :current-track-result))) + (tracks (session-value :current-track-result))) (when tracks (html ((:div :class "edit-tracks") ((:form :method "POST") Modified: branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/url/cached-url-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -17,6 +17,7 @@ (cond ((scan "^[a-zA-Z]+://" url) url) (t (render-uri (puri:merge-uris url base-url) nil)))) +#+(or) (defun cache-local-hrefs (data uri user depth &key (follow-links nil) (force nil)) (let ((seen (make-hash-table :test #'equal))) (flet ((make-local-cache-link (target-string start end match-start match-end @@ -49,6 +50,7 @@ (setf data (regex-replace-all *a-href-scanner* data #'make-local-cache-link))) data))) +#+(or) (defun make-cached-url-from-url (url &key parent-url user (depth 1) (force nil) (follow-links nil)) (setf url (normalize-url url)) @@ -82,15 +84,15 @@ (defclass cached-url-handler (object-handler) ((require-user-flag :initform :cache))) -(defmethod object-handler-get-object ((handler cached-url-handler) req) - (find-store-object (parse-url req) :class 'cached-url)) +(defmethod object-handler-get-object ((handler cached-url-handler)) + (find-store-object (parse-url) :class 'cached-url)) -(defmethod handle-object ((handler cached-url-handler) (url (eql nil)) req) - (with-bknr-page (req :title "No such cached url") +(defmethod handle-object ((handler cached-url-handler) (url (eql nil))) + (with-bknr-page (:title "No such cached url") (:p "No such cached url"))) -(defmethod handle-object ((handler cached-url-handler) url req) - (with-bknr-http-response (req :content-type (cached-url-content-type url)) - (with-http-body (req *ent*) +(defmethod handle-object ((handler cached-url-handler) url) + (with-http-response (:content-type (cached-url-content-type url)) + (with-http-body () (blob-to-stream url *html-stream*) (finish-output *html-stream*)))) \ No newline at end of file Modified: branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -8,13 +8,14 @@ (defclass submit-url-handler (form-handler) ()) -(defmethod authorized-p ((handler form-handler) req) - (not (equal (bknr-request-user req) (find-user "anonymous")))) +(defmethod authorized-p ((handler form-handler)) + (not (equal (bknr-request-user) (find-user "anonymous")))) -(defmethod handle-form ((handler submit-url-handler) action req) - (with-bknr-page (req :title #?"submit url") - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) - (with-query-params (req url title redirect) +#+(or) +(defmethod handle-form ((handler submit-url-handler) action) + (with-bknr-page (:title #?"submit url") + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) + (with-query-params (url title redirect) (html (:p "Drag this link to your bookmark bar: " ((:a :href (format nil "javascript:document.location.href=\"~a~a?title=\"+escape(document.title)+\"&url=\"+escape(document.location.href)+\"&redirect=1&keyword=fastsubmit\"" @@ -23,10 +24,10 @@ "bknr-url"))) (submit-url-form :url url :title title :keywords keywords :redirect redirect))))) -(defmethod handle-form ((handler submit-url-handler) (action (eql :submit)) - req) - (with-query-params (req title url description cache redirect) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) +#+(or) +(defmethod handle-form ((handler submit-url-handler) (action (eql :submit))) + (with-query-params (title url description cache redirect) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (handler-case (progn ;;; verify form parameters (ensure-form-field title) @@ -34,12 +35,12 @@ (setf url (normalize-url url)) (ensure-form-field keywords) (if (and cache - (not (user-has-flag (bknr-request-user req) :cache))) + (not (user-has-flag (bknr-request-user) :cache))) (error (make-condition 'form-not-authorized-condition :reason "You do not have the right to cache objects"))) (when cache - (make-cached-url-from-url url :user (bknr-request-user req) :depth 1 + (make-cached-url-from-url url :user (bknr-request-user) :depth 1 :force nil)) (let ((url-obj (url-with-url url))) @@ -54,11 +55,11 @@ :description description :keywords keywords :date (get-universal-time) - :submitter (bknr-request-user req)))) + :submitter (bknr-request-user)))) (declare (ignore submission)) - (redirect (if redirect url "/url") req)))) + (redirect (if redirect url "/url"))))) (form-field-missing-condition (e) - (with-bknr-page (req :title #?"submit url") + (with-bknr-page (:title #?"submit url") ((:h2 :class "error") "Please fill field " (:princ-safe (form-field-missing-condition-field e)) "!") (submit-url-form :url url :title title :description description Modified: branches/trunk-reorg/bknr/modules/url/url-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/url/url-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/url/url-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,18 +9,18 @@ (defclass url-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler url-handler) req) - (find-store-object (parse-url req) :class 'url)) +(defmethod object-handler-get-object ((handler url-handler)) + (find-store-object (parse-url) :class 'url)) -(defmethod handle-object ((handler url-handler) (url (eql nil)) req) - (redirect "/url-page" req)) +(defmethod handle-object ((handler url-handler) (url (eql nil))) + (redirect "/url-page")) -(defmethod handle-object ((handler url-handler) url req) +(defmethod handle-object ((handler url-handler) url) (let ((submissions (sort (group-on (url-submissions url) :key #'(lambda (submission) (get-daytime (url-submission-date submission)))) #'> :key #'car))) - (with-bknr-page (req :title #?"url page for $((url-url url))") + (with-bknr-page (:title #?"url page for $((url-url url))") (:p "keywords: " (mapc #'url-keyword-link (url-keywords url))) (:p (url-submissions-page submissions :full t))))) @@ -28,77 +28,76 @@ (defclass url-redirect-handler (url-handler) ()) -(defmethod handle-object ((handler url-redirect-handler) url req) +(defmethod handle-object ((handler url-redirect-handler) url) (if url - (redirect (url-url url) req) - (redirect "/url-page" req))) + (redirect (url-url url)) + (redirect "/url-page"))) (defclass url-page-handler (object-date-list-handler) ()) (defmethod object-list-handler-title ((handler url-page-handler) - object req) + object) "bknr urls") (defmethod object-list-handler-rss-link ((handler url-page-handler) - object req) + object) "/url-rss") -(defmethod object-list-handler-get-objects ((handler url-page-handler) object req) +(defmethod object-list-handler-get-objects ((handler url-page-handler) object) (mapcar #'url-latest-submission (all-urls))) (defmethod object-date-list-handler-grouped-objects ((handler url-page-handler) - object req) - (let* ((date (next-day 1 :start (object-date-list-handler-date handler object req))) + object) + (let* ((date (next-day 1 :start (object-date-list-handler-date handler object))) (submissions (remove-if #'(lambda (submission) (> (url-submission-date submission) date)) - (object-list-handler-get-objects handler object req)))) + (object-list-handler-get-objects handler object)))) (sort (group-on submissions :key #'(lambda (submission) (get-daytime (url-submission-date submission)))) #'> :key #'car))) -(defmethod handle-object ((handler url-page-handler) object req) - (let ((submissions (object-date-list-handler-grouped-objects handler object req))) - (with-bknr-page (req :title (object-list-handler-title - handler object req)) +(defmethod handle-object ((handler url-page-handler) object) + (let ((submissions (object-date-list-handler-grouped-objects handler object))) + (with-bknr-page (:title (object-list-handler-title + handler object)) (:p "random keywords: " (url-random-keywords)) - (:p ((:a :href (object-list-handler-rss-link handler object req)) "rss") + (:p ((:a :href (object-list-handler-rss-link handler object)) "rss") " " ((:a :href "/submit-url") "submit an url")) (url-submissions-page submissions - :start-date (object-date-list-handler-date handler object req))))) + :start-date (object-date-list-handler-date handler object))))) (defclass url-submitter-handler (url-page-handler) ()) -(defmethod object-handler-get-object ((handler url-submitter-handler) - req) - (find-store-object (parse-url req) :class 'user +(defmethod object-handler-get-object ((handler url-submitter-handler)) + (find-store-object (parse-url) :class 'user :query-function #'find-user)) (defmethod object-list-handler-get-objects ((handler url-submitter-handler) - user req) + user) (copy-list (get-user-url-submissions user))) (defmethod object-list-handler-title ((handler url-submitter-handler) - user req) + user) (format nil "bknr urls submitted by ~a" (user-full-name user))) (defmethod object-list-handler-rss-link ((handler url-submitter-handler) - user req) + user) (format nil "/url-submitter-rss/~A" (user-login user))) -(defmethod handle-object ((handler url-submitter-handler) user req) - (let ((submissions (object-date-list-handler-grouped-objects handler user req))) - (with-bknr-page (req :title (object-list-handler-title - handler user req)) - ((:a :href (object-list-handler-rss-link handler user req)) "rss") +(defmethod handle-object ((handler url-submitter-handler) user) + (let ((submissions (object-date-list-handler-grouped-objects handler user))) + (with-bknr-page (:title (object-list-handler-title + handler user)) + ((:a :href (object-list-handler-rss-link handler user)) "rss") (url-submissions-page submissions :start-date (object-date-list-handler-date - handler user req) + handler user) :url (format nil "/url-submitter/~A" (user-login user)))))) @@ -106,21 +105,21 @@ ()) (defmethod object-list-handler-get-objects ((handler url-keyword-handler) - keyword req) + keyword) (mapcar #'url-latest-submission (get-keyword-urls keyword))) (defmethod handle-object ((handler url-keyword-handler) - (keyword (eql nil)) req) - (with-bknr-page (req :title "all-url-keywords") + (keyword (eql nil))) + (with-bknr-page (:title "all-url-keywords") (:ul (dolist (keyword (all-url-keywords)) (html (:li (url-keyword-link keyword))))))) (defmethod object-list-handler-title ((handler url-keyword-handler) - keyword req) + keyword) (format nil "bknr keyword urls: ~a" keyword)) (defmethod object-list-handler-rss-link ((handler url-keyword-handler) - keyword req) + keyword) (format nil "/url-keyword-rss/~A" (string-downcase (symbol-name keyword)))) @@ -129,31 +128,31 @@ ()) (defmethod object-list-handler-get-objects ((handler url-union-handler) - keywords req) + keywords) (mapcar #'url-latest-submission (get-keywords-union-urls keywords))) (defmethod object-list-handler-title ((handler url-union-handler) - keywords req) + keywords) (format nil "bknr union keyword urls: ~a" keywords)) (defmethod object-list-handler-rss-link ((handler url-union-handler) - keyword req) + keyword) (format nil "/url-union-rss/~A" - (parse-url req))) + (parse-url))) (defclass url-intersection-handler (url-page-handler keywords-handler) ()) (defmethod object-list-handler-get-objects ((handler url-intersection-handler) - keywords req) + keywords) (mapcar #'url-latest-submission (get-keywords-intersection-urls keywords))) (defmethod object-list-handler-title ((handler url-intersection-handler) - keywords req) + keywords) (format nil "bknr intersection keyword urls: ~a" keywords)) (defmethod object-list-handler-rss-link ((handler url-intersection-handler) - keyword req) + keyword) (format nil "/url-intersection-rss/~A" - (parse-url req))) + (parse-url))) Modified: branches/trunk-reorg/bknr/tools/make-core.lisp ============================================================================== --- branches/trunk-reorg/bknr/tools/make-core.lisp (original) +++ branches/trunk-reorg/bknr/tools/make-core.lisp Tue Jan 29 07:19:19 2008 @@ -7,8 +7,10 @@ (defparameter *src-directory* (make-pathname :directory (pathname-directory *load-truename*))) (defparameter *bknr-directory* (merge-pathnames #p"bknr-svn/" (user-homedir-pathname))) -#+cmu #-cmu19b -(load (merge-pathnames "bknr/patches/patch-around-mop-cmucl19a.lisp" *bknr-directory*)) +#+cmu +(load (merge-pathnames "bknr/datastore/patches/patch-around-mop-cmucl19.lisp" *bknr-directory*)) +#+cmu +(pushnew :rune-is-integer *features*) #-asdf (error "No ASDF found in image, please provide one through the default image or home:init.lisp") Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd ============================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Tue Jan 29 07:19:19 2008 @@ -23,6 +23,7 @@ :cl-ppcre :cl-gd :kmrcl + :alexandria :md5 :cxml :unit-test @@ -33,7 +34,7 @@ :puri :bknr-datastore :bknr-data-impex - :parenscript) + :parenscript) :components ((:file "packages") @@ -110,7 +111,6 @@ "web-utils"))) :depends-on ("sysclasses" "packages" "rss")) - #+notyet (:module "images" :components ((:file "image") (:file "image-tags" :depends-on ("image")) 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 Tue Jan 29 07:19:19 2008 @@ -5,54 +5,54 @@ (defclass edit-images-handler (edit-object-handler image-handler) ((require-user-flag :initform :admin))) -(defmethod object-handler-get-object ((handler edit-images-handler) req) +(defmethod object-handler-get-object ((handler edit-images-handler)) (remove nil (mapcar #'(lambda (id) (find-store-object id :class 'store-image :query-function #'store-image-with-name)) - (query-param-list req "image-id")))) + (query-param-list "image-id")))) -(defmethod handle-object-form ((handler edit-images-handler) action images req) - (with-bknr-page (req :title #?"edit-images") +(defmethod handle-object-form ((handler edit-images-handler) action images) + (with-bknr-page (:title #?"edit-images") (search-image-collection :title "search images") (edit-image-collection :title "edit images"))) (defmethod handle-object-form ((handler edit-images-handler) - (action (eql :delete)) images req) + (action (eql :delete)) images) (let ((names (mapcar #'store-image-name images))) (mapc #'delete-object images) - (setf (session-variable :current-query-result) - (set-difference (session-variable :current-query-result) + (setf (session-value :current-query-result) + (set-difference (session-value :current-query-result) images)) - (with-bknr-page (req :title #?"delete images") + (with-bknr-page (:title #?"delete images") (html (:h2 "Deleted images:") (dolist (name names) (html (:princ-safe name)(:br))))))) (defmethod handle-object-form ((handler edit-images-handler) (action (eql :add-keywords)) - images req) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + images) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (dolist (image images) (store-object-add-keywords image 'keywords keywords)) - (with-bknr-page (req :title #?"edit-all-images") + (with-bknr-page (:title #?"edit-all-images") (image-collection images :title (format nil "Added keywords ~a to images:" keywords))))) (defmethod handle-object-form ((handler edit-images-handler) (action (eql :remove-keywords)) - images req) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + images) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (dolist (image images) (store-object-remove-keywords image 'keywords keywords)) - (with-bknr-page (req :title #?"edit-all-images") + (with-bknr-page (:title #?"edit-all-images") (image-collection images :title (format nil "Removed keywords ~a from images:" keywords))))) (defmethod handle-object-form ((handler edit-images-handler) (action (eql :assign-individual-keywords)) - images req) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword-img") + images) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword-img") :remove-empty nil)) (assigned-images (loop for keys on keywords by #'cddr for keyword = (if (eq (car keys) :||) @@ -63,29 +63,29 @@ image) do (store-object-add-keywords image 'keywords (list keyword)) and collect image))) - (with-bknr-page (req :title #?"edit-all-images") + (with-bknr-page (:title #?"edit-all-images") (image-collection assigned-images :title "Add keywords to images:")))) (defmethod handle-object-form ((handler edit-images-handler) (action (eql :search)) - images req) - (let* ((keywords (remove :|| (keywords-from-query-param-list (query-param-list req "keyword")))) - (operator (query-param req "operator")) - (name (query-param req "name"))) - (with-bknr-page (req :title #?"edit-images") + images) + (let* ((keywords (remove :|| (keywords-from-query-param-list (query-param-list "keyword")))) + (operator (query-param "operator")) + (name (query-param "name"))) + (with-bknr-page (:title #?"edit-images") (search-image-collection :title "search images") - (setf (session-variable :current-query-result) + (setf (session-value :current-query-result) (if keywords (ecase (make-keyword-from-string operator) (:or (get-keywords-union-store-images keywords)) (:and (get-keywords-intersection-store-images keywords))) (all-store-images))) (when name - (setf (session-variable :current-query-result) + (setf (session-value :current-query-result) (remove-if-not #'(lambda (img) (scan name (store-image-name img))) - (session-variable :current-query-result)))) + (session-value :current-query-result)))) (edit-image-collection)))) (defclass edit-image-handler (edit-object-handler image-handler) @@ -106,24 +106,24 @@ (:div (submit-button "edit" "Edit keywords"))))))) -(defmethod handle-object-form ((handler edit-image-handler) action image req) +(defmethod handle-object-form ((handler edit-image-handler) action image) (let ((image-name (store-image-name image))) - (with-bknr-page (req :title #?"bknr image ${image-name}") + (with-bknr-page (:title #?"bknr image ${image-name}") (show-image-editor image)))) (defmethod handle-object-form ((handler edit-image-handler) - (action (eql :delete)) image req) + (action (eql :delete)) image) (let ((name (store-image-name image))) (delete-object image) - (with-bknr-page (req :title #?"delete images") + (with-bknr-page (:title #?"delete images") (html (:h2 "Deleted image " (:princ-safe name)))))) (defmethod handle-object-form ((handler edit-image-handler) - (action (eql :edit)) image req) + (action (eql :edit)) image) (let ((name (store-image-name image)) - (add-keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (remove-keywords (keywords-from-query-param-list (query-param-list req "remove-keyword")))) - (with-bknr-page (req :title #?"edit image $(name)") + (add-keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (remove-keywords (keywords-from-query-param-list (query-param-list "remove-keyword")))) + (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)))) Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -2,23 +2,15 @@ (enable-interpol-syntax) -(defun emit-image-to-browser (req image image-format &key (quality -1) (date 0) cache-sticky max-age) - (with-bknr-http-response (req :content-type (image-content-type image-format)) +(defun emit-image-to-browser (image image-format &key (quality -1) (date 0) cache-sticky max-age) + (with-http-response (:content-type (image-content-type image-format)) (when cache-sticky - (setf (reply-header-slot-value req :expires) (#-allegro - universal-time-to-date - #+allegro - net.aserve::universal-time-to-date - (+ (get-universal-time) (* 365 24 60 60))))) + (setf (header-out :expires) (rfc-1123-date (+ (get-universal-time) (* 365 24 60 60))))) (when max-age - (setf (reply-header-slot-value req :cache-control) (format nil "max-age=~A" max-age))) + (setf (header-out :cache-control) (format nil "max-age=~A" max-age))) (unless (zerop date) - (setf (reply-header-slot-value req :last-modified) (#-allegro - universal-time-to-date - #+allegro - net.aserve::universal-time-to-date - date))) - (with-http-body (req *ent*) + (setf (header-out :last-modified) (rfc-1123-date date))) + (with-http-body () (setf (save-alpha-p :image image) t) (if (member image-format '(:jpg :jpeg)) (write-image-to-stream *html-stream* image-format :image image :quality quality) @@ -40,63 +32,61 @@ (defclass image-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler image-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler image-handler)) + (let ((id-or-name (parse-url))) (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name))) (defclass browse-image-handler (image-handler) ()) -(defmethod handle-object ((page-handler browse-image-handler) image req) +(defmethod handle-object ((page-handler browse-image-handler) image) (let ((image-name (store-image-name image)) (image-id (store-object-id image))) - (with-bknr-page (req :title #?"bknr image ${image-name}") + (with-bknr-page (:title #?"bknr image ${image-name}") (image-browser :id image-id)))) (defclass image-page-handler (object-list-handler) ()) -(defmethod object-list-handler-title ((handler image-page-handler) object req) +(defmethod object-list-handler-title ((handler image-page-handler) object) "bknr images") -(defmethod object-list-handler-rss-link ((handler image-page-handler) object req) +(defmethod object-list-handler-rss-link ((handler image-page-handler) object) "/image-rss") -(defmethod object-list-handler-get-objects ((handler image-page-handler) object req) +(defmethod object-list-handler-get-objects ((handler image-page-handler) object) (all-store-images)) (defun make-keyword-results (images) (loop for i on images by #'(lambda (seq) (subseq seq 30)) collect (subseq i 0 30))) -(defmethod handle-object ((handler image-page-handler) images req) - (let ((results (make-keyword-results (object-list-handler-get-objects handler images req)))) - (with-bknr-page (req :title (object-list-handler-title handler images req)) - (cmslink (object-list-handler-rss-link handler images req) "rss") +(defmethod handle-object ((handler image-page-handler) images) + (let ((results (make-keyword-results (object-list-handler-get-objects handler images)))) + (with-bknr-page (:title (object-list-handler-title handler images)) + (cmslink (object-list-handler-rss-link handler images) "rss") (image-page results)))) (defclass upload-image-handler (form-handler) ()) (defmethod handle-form ((handler upload-image-handler) - (action null) - req) - (with-bknr-page (req :title "Image upload") + (action null)) + (with-bknr-page (:title "Image upload") (html "Please upload your image" ((:form :enctype "multipart/form-data" :method "post") "File: " ((:input :type "file" :name "file")) :br ((:input :type "submit" :name "action" :value "upload")))))) (defmethod handle-form ((handler upload-image-handler) - (action (eql :upload)) - req) - (with-bknr-page (req :title "Image upload result") - (let ((file-pathname (cdr (find "file" (request-uploaded-files req) :key #'car :test #'equal)))) + (action (eql :upload))) + (with-bknr-page (:title "Image upload result") + (let ((file-pathname (cdr (find "file" (request-uploaded-files) :key #'car :test #'equal)))) (unless file-pathname (error "no file uploaded")) - (with-query-params (req name keyword) + (with-query-params (name keyword) (let* ((image (import-image file-pathname - :user (bknr-request-user req) + :user (bknr-request-user) :keywords (list keyword) :keywords-from-dir nil)) (image-id (store-object-id image))) @@ -113,54 +103,54 @@ ()) (defmethod handle-object ((handler image-keyword-handler) - (keyword (eql nil)) req) - (with-bknr-page (req :title "No keyword was given") + (keyword (eql nil))) + (with-bknr-page (:title "No keyword was given") (html "No keyword was given!"))) -(defmethod object-list-handler-get-objects ((handler image-keyword-handler) keyword req) +(defmethod object-list-handler-get-objects ((handler image-keyword-handler) keyword) (get-keyword-store-images keyword)) -(defmethod object-list-handler-title ((handler image-keyword-handler) keyword req) +(defmethod object-list-handler-title ((handler image-keyword-handler) keyword) (format nil "bknr keyword images: ~a" keyword)) -(defmethod object-list-handler-rss-link ((handler image-keyword-handler) keyword req) +(defmethod object-list-handler-rss-link ((handler image-keyword-handler) keyword) (format nil "/keyword-rss/~A" (string-downcase (symbol-name keyword)))) (defclass image-union-handler (image-page-handler keywords-handler) ()) -(defmethod object-list-handler-get-objects ((handler image-union-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler image-union-handler) keywords) (get-keywords-union-store-images keywords)) -(defmethod object-list-handler-title ((handler image-union-handler) keywords req) +(defmethod object-list-handler-title ((handler image-union-handler) keywords) (format nil "bknr union images: ~a" keywords)) -(defmethod object-list-handler-rss-link ((handler image-union-handler) keywords req) - (format nil "/union-rss/~A" (parse-url req))) +(defmethod object-list-handler-rss-link ((handler image-union-handler) keywords) + (format nil "/union-rss/~A" (parse-url))) (defclass image-intersection-handler (image-page-handler keywords-handler) ()) -(defmethod object-list-handler-get-objects ((handler image-intersection-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler image-intersection-handler) keywords) (get-keywords-intersection-store-images keywords)) -(defmethod object-list-handler-title ((handler image-intersection-handler) keywords req) +(defmethod object-list-handler-title ((handler image-intersection-handler) keywords) (format nil "bknr intersection images: ~a" keywords)) -(defmethod object-list-handler-rss-link ((handler image-intersection-handler) keywords req) - (format nil "/intersection-rss/~A" (parse-url req))) +(defmethod object-list-handler-rss-link ((handler image-intersection-handler) keywords) + (format nil "/intersection-rss/~A" (parse-url))) ;;; rss image feeds #| (defclass rss-image-handler (object-rss-handler image-page-handler) ()) -(defmethod create-object-rss-feed ((handler rss-image-handler) object req) +(defmethod create-object-rss-feed ((handler rss-image-handler) object) (let* ((url (website-url (page-handler-site handler))) (image-items (mapcar #'(lambda (image) (store-image-to-rss-item image :url url)) - (subseq (sort (object-list-handler-get-objects handler object req) + (subseq (sort (object-list-handler-get-objects handler object) #'> :key #'blob-timestamp) 0 20)))) (if image-items @@ -168,7 +158,7 @@ :channel (make-instance 'rss-channel :about (render-uri url nil) - :title (object-list-handler-title handler object req) + :title (object-list-handler-title handler object) :link (render-uri url nil) :items (mapcar #'rss-item-link image-items)) :items image-items) @@ -189,18 +179,18 @@ (defclass xml-image-browser-handler (image-handler xml-object-handler) ()) -(defmethod xml-object-handler-show-object ((handler xml-image-browser-handler) image req) +(defmethod xml-object-handler-show-object ((handler xml-image-browser-handler) image) (store-image-xml-info image)) (defclass xml-image-query-handler (xml-object-list-handler) ()) -(defmethod object-list-handler-get-objects ((handler xml-image-query-handler) keywords req) +(defmethod object-list-handler-get-objects ((handler xml-image-query-handler) keywords) (if keywords (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string keywords)) (class-instances 'store-image))) -(defmethod object-list-handler-show-object-xml ((handler xml-image-query-handler) image req) +(defmethod object-list-handler-show-object-xml ((handler xml-image-query-handler) image) (store-image-xml-info image)) (define-bknr-webserver-module images Modified: branches/trunk-reorg/bknr/web/src/images/image-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-tags.lisp Tue Jan 29 07:19:19 2008 @@ -4,7 +4,7 @@ (define-bknr-tag image-page (results &key) (let* ((num-pages (length results)) - (page (parse-integer (or (query-param *req* "page") "0")))) + (page (parse-integer (or (query-param "page") "0")))) (if (>= page num-pages) (html "No such page") (let ((images (nth page results))) @@ -13,7 +13,7 @@ (html (:princ " ") (if (= i page) (html (:princ-safe i)) - (html (cmslink (format nil "~A?page=~A" (uri-path (request-uri *req*)) i) (:princ-safe i)))) + (html (cmslink (format nil "~A?page=~A" (request-uri) i) (:princ-safe i)))) (:princ " "))))))) (define-bknr-tag banner (&key link keyword width height) @@ -101,11 +101,11 @@ nconc images))))) (define-bknr-tag reset-results () - (setf (session-variable :current-query-name) nil - (session-variable :current-thumbnail-layout) nil - (session-variable :current-query-result) nil)) + (setf (session-value :current-query-name) nil + (session-value :current-thumbnail-layout) nil + (session-value :current-query-result) nil)) -(defun edit-image-collection (&key title (images (session-variable :current-query-result))) +(defun edit-image-collection (&key title (images (session-value :current-query-result))) (format t "class ~a subtypep ~a~%" (class-of (first images)) (subtypep (class-of (first images)) (find-class 'store-image))) (unless (subtypep (class-of (first images)) (find-class 'store-image)) (reset-results) Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Tue Jan 29 07:19:19 2008 @@ -162,28 +162,24 @@ (defclass imageproc-handler (image-handler) ()) -(defmethod handle-object ((page-handler imageproc-handler) (image (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((page-handler imageproc-handler) (image (eql nil))) + (error-404)) -(defmethod handle-object ((page-handler imageproc-handler) image req) - (with-bknr-http-response (req :content-type (image-content-type (image-type-keyword image))) - (let ((ims (header-slot-value req :if-modified-since)) +(defmethod handle-object ((page-handler imageproc-handler) image) + (format t "if-modfied-since not implemented for hunchentoot~%") + (with-http-body () + (imageproc image (cdr (decoded-handler-path page-handler)))) + #+(or) + (with-http-response (:content-type (image-content-type (image-type-keyword image))) + (let ((ims (header-in :if-modified-since)) (changed-time (blob-timestamp image))) - (setf (net.aserve::last-modified *ent*) changed-time) - (setf (reply-header-slot-value req :last-modified) (#-allegro - universal-time-to-date - #+allegro - net.aserve::universal-time-to-date - changed-time)) + (setf (header-out :last-modified) (rfc-1123-date changed-time)) (if (and ims - (<= changed-time (#-allegro - date-to-universal-time - #+allegro - net.aserve::date-to-universal-time ims))) + (<= changed-time (date-to-universal-time ims))) (progn - (setf (request-reply-code req) *response-not-modified*) + (setf (return-code) +http-not-modified+) (format t "; image ~A not changed~%" image) - (with-http-body (req *ent*))) - (with-http-body (req *ent*) - (imageproc image (cdr (decoded-handler-path page-handler req)))))))) + (with-http-body ())) + (with-http-body () + (imageproc image (cdr (decoded-handler-path page-handler)))))))) Modified: branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,11 +5,11 @@ (defclass image-import-handler (import-handler) ()) -(defmethod import-handler-spool-files ((handler image-import-handler) req) - (image-directory-recursive (import-handler-import-pathname handler req))) +(defmethod import-handler-spool-files ((handler image-import-handler)) + (image-directory-recursive (import-handler-import-pathname handler))) -(defmethod handle-form ((handler image-import-handler) action req) - (with-bknr-page (req :title #?"image import directory") +(defmethod handle-form ((handler image-import-handler) action) + (with-bknr-page (:title #?"image import directory") ((:form :method "post") ((:div :class "keyword-choose") (if (class-subclasses 'store-image) @@ -26,29 +26,29 @@ (:div (submit-button "import" "Import")))) ((:div :class "import-list") (:h2 "Images present in import spool:") - (loop for file in (import-handler-spool-files handler req) + (loop for file in (import-handler-spool-files handler) do (html (:princ-safe (namestring file)) (:br)))))) -(defmethod import-handler-import-files ((handler image-import-handler) req) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (spool-dir (import-handler-import-pathname handler req)) - (class-name (apply #'find-symbol (reverse (split "::?" (query-param req "class-name")))))) +(defmethod import-handler-import-files ((handler image-import-handler)) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (spool-dir (import-handler-import-pathname handler)) + (class-name (apply #'find-symbol (reverse (split "::?" (query-param "class-name")))))) (import-directory spool-dir :class-name class-name - :user (bknr-request-user req) + :user (bknr-request-user) :keywords keywords :spool (import-handler-spool-dir handler) - :keywords-from-dir (query-param req "keyfromdir")))) + :keywords-from-dir (query-param "keyfromdir")))) -(defmethod handle-form ((handler image-import-handler) (action (eql :import)) req) - (let* ((import-log (import-handler-import-files handler req)) +(defmethod handle-form ((handler image-import-handler) (action (eql :import))) + (let* ((import-log (import-handler-import-files handler)) (successful-images (remove-if-not #'(lambda (element) (typep element 'store-image)) import-log :key #'cdr)) (error-log (remove-if-not #'(lambda (element) (typep element 'error)) import-log :key #'cdr))) - (with-bknr-page (req :title #?"bknr import log") + (with-bknr-page (:title #?"bknr import log") ((:div :class "error-log") (:h2 "Errors during import:") (loop for (file . error) in error-log do (typecase error Modified: branches/trunk-reorg/bknr/web/src/images/session-image.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/session-image.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/session-image.lisp Tue Jan 29 07:19:19 2008 @@ -6,10 +6,10 @@ (defclass session-image-handler (page-handler) ()) -(defmethod handle ((handler session-image-handler) req) - (let ((random-string (or (session-variable :random-string) +(defmethod handle ((handler session-image-handler)) + (let ((random-string (or (session-value :random-string) (format nil "~(~36,3,'0R~)" (+ 1296 (random (- 46656 1296))))))) - (setf (session-variable :random-string) random-string) + (setf (session-value :random-string) random-string) (with-image* ((* 5 *session-image-point-size*) (* 2 *session-image-point-size*)) (setf (transparent-color) (allocate-color 255 255 255)) (loop with x-min = (* 5 *session-image-point-size*) @@ -34,6 +34,6 @@ finally (with-image (result-image (- x-max x-min) (- y-max y-min)) (setf (transparent-color result-image) (allocate-color 255 255 255 :image result-image)) (copy-image *default-image* result-image x-min y-min 0 0 (image-width result-image) (image-height result-image)) - (with-bknr-http-response (req :content-type "image/png") - (with-http-body (req *ent*) + (with-http-response (:content-type "image/png") + (with-http-body () (write-image-to-stream *html-stream* :png :image result-image)))))))) 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 Tue Jan 29 07:19:19 2008 @@ -175,6 +175,7 @@ :cl-gd :cl-interpol :cl-ppcre + :alexandria :hunchentoot :cxml-xmls :xhtml-generator @@ -188,10 +189,12 @@ :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:export #:*req* - #:*ent* + (:shadowing-import-from :hunchentoot #:host) + (:shadowing-import-from :alexandria #:array-index) + (:export #:*html-stream* #:*user* - #:session-variable + #:with-http-request + #:with-http-body #:request-variable #:with-query-params #:define-bknr-tag @@ -247,7 +250,7 @@ #:parse-date-field #:keyword-choose-dialog #:navi-button - #:with-bknr-http-response + #:with-http-response #:upload #:upload-name @@ -291,6 +294,7 @@ #:host #:publish-site #:publish-handler + #:unpublish #:handle-object #:handle-object-form @@ -368,10 +372,9 @@ #:bknr-session-user #:bknr-session-start-time #:bknr-session-last-used - #:bknr-session-variables + #:bknr-session-values + #:bknr-session-host - #:http-session - #:http-session-host #:host-name #:bknr-request-user #:bknr-request @@ -451,4 +454,5 @@ :cxml :bknr.web :bknr.impex + :hunchentoot :xhtml-generator)) Modified: branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp Tue Jan 29 07:19:19 2008 @@ -35,6 +35,7 @@ :items items))) (error "not a valid atom feed"))) +#+(or) (defun parse-atom-feed (rss-feed) (let ((xml (typecase rss-feed (string (with-input-from-string (s rss-feed) Modified: branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp Tue Jan 29 07:19:19 2008 @@ -34,6 +34,7 @@ (error "no channel in 0.91 feed"))) (error "not a valid rss feed"))) +#+(or) (defun parse-rss091-feed (rss-feed) (let ((xml (typecase rss-feed (string (with-input-from-string (s rss-feed) Modified: branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp Tue Jan 29 07:19:19 2008 @@ -63,6 +63,7 @@ (error "no channel in 0.91 feed"))) (error "not a valid rss feed"))) +#+(or) (defun parse-rss10-feed (rss-feed) (let ((xml (parse rss-feed :compress-whitespace nil))) (when xml Modified: branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp Tue Jan 29 07:19:19 2008 @@ -41,6 +41,7 @@ (error "no channel in 2.0 feed"))) (error "not a valid rss feed"))) +#+(or) (defun parse-rss20-feed (rss-feed) (let ((xml (typecase rss-feed (string (with-input-from-string (s rss-feed) Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp Tue Jan 29 07:19:19 2008 @@ -3,12 +3,13 @@ (defclass bknr-authorizer () ()) -#+cmu -(defmethod http-request-remote-host ((req http-request)) - (let ((remote-host (socket:remote-host (request-socket req))) +(defmethod http-request-remote-host () + (format *debug-io* "can't determin originating host yet~%") + #+(or) + (let ((remote-host (socket:remote-host (request-socket))) (forwarded-for (regex-replace "^.*?([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+).*$" - (header-slot-value req :x-forwarded-for) + (header-slot-value :x-forwarded-for) "\\1"))) (when (and forwarded-for (equal "127.0.0.1" (socket:ipaddr-to-dotted remote-host))) @@ -16,23 +17,13 @@ (setf remote-host (socket:dotted-to-ipaddr forwarded-for))) (find-host :create t :ipaddr remote-host))) -(defun session-from-request (req) +(defun session-from-request () "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter" - (with-cookies (req bknr-sessionid) - (when (and (not bknr-sessionid) - (request-query req)) - (setq bknr-sessionid (query-param req "bknr-sessionid")) - #+(or) - (when bknr-sessionid - ;; XXX convert parameter to cookie value - this against - ;; aserve's advertised protocol which demands that - ;; set-cookie-header must not be called before - ;; with-http-response - (set-cookie-header req :name "bknr-sessionid" :value bknr-sessionid :expires :never))) - (find-session bknr-sessionid))) + (start-session) + (session-value 'bknr-session)) -(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer) req) - (with-query-params (req __username __password) +(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer)) + (with-query-params (__username __password) (when (and __username (not (equal __username ""))) (let ((user (find-user __username))) (when user @@ -41,53 +32,17 @@ user (warn "login failure for user ~a~%" user))))))) -(defmethod session-from-request-parameters ((authorizer bknr-authorizer) req) - (let ((user (find-user-from-request-parameters authorizer req))) - (when user - (make-user-session req user :old-session (session-from-request req))))) - -(defvar *global-anonymous-session* nil) - -(defun global-anonymous-session () - (or *global-anonymous-session* - (setf *global-anonymous-session* (make-instance 'http-session :host nil :user (find-user "anonymous"))))) - -(defun make-anonymous-session (req) - (make-instance 'http-session - :user (find-user "anonymous") - :host (http-request-remote-host req))) - -(defun make-user-session (req user &key old-session) - (set-user-last-login user (get-universal-time)) - (let ((new-session (make-instance 'http-session - :user user - :host (http-request-remote-host req)))) - (when old-session - ;; copy session variables from old session - (setf (bknr-session-variables new-session) - (bknr-session-variables old-session)) - (drop-session old-session)) - new-session)) - -(defmethod authorize ((authorizer bknr-authorizer) - (req http-request) - ent) +(defmethod authorize ((authorizer bknr-authorizer)) ;; Catch any errors that occur during request body processing + (start-session) (handler-case - ;; first check session cookie or bknr-sessionid parameter. the - ;; session cookie is set in the with-bknr-http-response macro to - ;; follow aserve's documented protocol for setting cookies - (let ((session (or (session-from-request-parameters authorizer req) - (session-from-request req) - (make-anonymous-session req)))) - (when session - (bknr-session-touch session) - (change-class req 'bknr-request :session session) - (return-from authorize t))) + (when (session-value 'bknr-session) + (return-from authorize t)) (error (e) (format t "; Caught error ~A during request processing~%" e) - (http-error req *response-bad-request* (princ-to-string e)))) + (setf (return-code) +http-bad-request+) + (princ-to-string e))) ;; unauthorized, come up with 401 response to the web browser - (redirect (website-make-path *website* "login") req) + (redirect "/login") :deny) Modified: branches/trunk-reorg/bknr/web/src/web/event-log.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/event-log.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/event-log.lisp Tue Jan 29 07:19:19 2008 @@ -35,8 +35,8 @@ (find (class-name class) *default-event-classes-to-suppress*)) (all-subclasses (find-class 'event)))) -(defun serve-event-class-documentation-request (req) - (with-bknr-page (req :title "event class documentation") +(defun serve-event-class-documentation-request () + (with-bknr-page (:title "event class documentation") (html (:table (:tr (:th "name") (:th "documentation")) @@ -53,8 +53,8 @@ (cmslink (format nil "event-log?show-only-class=~a" ,class-name) (:princ-safe (regex-replace ,class-name "-event$" "")))))) -(defun serve-event-log-request (req) - (with-query-params (req +(defun serve-event-log-request () + (with-query-params ( message show-only-class last-printed ;; Timestamp of last event printed (client-side session context) @@ -62,7 +62,7 @@ print-hours ;; number of hours to search print-count) ;; maximum number of events to print (when (and message (not (equal "" message))) - (make-event 'message-event :from (bknr-request-user req) :text message)) + (make-event 'message-event :from (bknr-request-user) :text message)) ;; Parameter parsing, will move to with-query-params soon (if (and last-printed (not (equal "" last-printed))) (setf last-printed (parse-integer last-printed)) @@ -74,14 +74,14 @@ (setf print-count "50")) (unless print-hours (setf print-hours "24")) - (with-bknr-page (req :title "event log") + (with-bknr-page (:title "event log") (let ((selected-classes (or (and show-only-class (list (find-class (find-symbol show-only-class (find-package "bknr"))))) - (selected-classes (request-query req)) - (mapcar #'find-class (get-user-preferences (bknr-request-user req) :event-log-classes)) + (selected-classes (request-query)) + (mapcar #'find-class (get-user-preferences (bknr-request-user) :event-log-classes)) (default-selected-classes)))) (unless show-only-class - (set-user-preferences (bknr-request-user req) :event-log-classes (mapcar #'class-name selected-classes))) + (set-user-preferences (bknr-request-user) :event-log-classes (mapcar #'class-name selected-classes))) ;; selected-classes contains the list of event classes to print. (html ((:form :action "/event-log" :method "post") 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 Tue Jan 29 07:19:19 2008 @@ -75,7 +75,6 @@ (when *website* (warn "Warning, *website* redefined with new website definition")) (setf *website* website) - (unpublish :all t) (publish-site *website*)) (defmethod show-handlers ((website website)) @@ -91,6 +90,7 @@ (format nil "~A~A" (website-base-href website) (relative path))) (defgeneric publish-handler (website handler)) +(defgeneric handler-matches (handler)) (defgeneric publish-site (website)) (defun handler-definition-name (handler-definition) @@ -135,7 +135,7 @@ (apply #'append (website-handler-definitions website) (mapcar #'(lambda (module-name) (or (gethash (symbol-name module-name) *website-modules*) - (warn "bknr module ~A not known" module-name))) + (error "bknr module ~A not known" module-name))) (website-modules website))))) (when (website-template-base-directory website) (setf (slot-value website 'template-handler) (make-instance 'template-handler @@ -147,14 +147,14 @@ (website-handlers website))) (mapc #'(lambda (handler) (publish-handler website handler)) - (website-handlers website))) + (website-handlers website)) + (pushnew 'bknr-dispatch *dispatch-table*)) (defmethod website-session-info ((website website)) (html ((:div :id "session-info") "local time is " (:princ-safe (format-date-time)) - (if (and (equal 'bknr-request (type-of *req*)) - (bknr-request-user *req*)) - (html ", logged in as " (html-link (bknr-request-user *req*))) + (if (bknr-request-user) + (html ", logged in as " (html-link (bknr-request-user))) (html ", not logged in"))))) (defclass page-handler () @@ -185,87 +185,95 @@ name (concatenate 'string "/" (string-downcase name)))))) -(defgeneric handle (page-handler req)) -(defgeneric authorized-p (page-handler req)) +(defmethod print-object ((handler page-handler) stream) + (print-unreadable-object (handler stream :type t) + (format stream "~A" (page-handler-prefix handler)))) + +(defgeneric handle (page-handler)) +(defgeneric authorized-p (page-handler)) (defgeneric page-handler-url (page-handler)) -(defmethod handler-path ((handler page-handler) req) - (subseq (uri-path (request-uri req)) +(defmethod handler-path ((handler page-handler)) + (subseq (request-uri) (length (page-handler-prefix handler)))) -(defmethod decoded-handler-path ((handler page-handler) req) - (mapcar #'uridecode-string +(defmethod decoded-handler-path ((handler page-handler)) + (mapcar #'url-decode (remove "" - (split "/" (handler-path handler req)) + (split "/" (handler-path handler)) :test #'equal))) -(defmethod parse-handler-url ((handler page-handler) req) - (values-list (decoded-handler-path handler req))) +(defmethod parse-handler-url ((handler page-handler)) + (values-list (decoded-handler-path handler))) (defmethod page-handler-url ((handler page-handler)) (merge-uris (parse-uri (page-handler-prefix handler)) (website-url (page-handler-site handler)))) -(defmethod authorized-p ((page-handler page-handler) req) +(defmethod authorized-p ((page-handler page-handler)) (with-slots (require-user-flag) page-handler (if (and require-user-flag (not (find require-user-flag - (user-flags (bknr-request-user req))))) + (user-flags (bknr-request-user))))) nil t))) -(defmethod invoke-handler ((handler page-handler) req ent) +(defmethod invoke-handler ((handler page-handler)) (let* ((*website* (page-handler-site handler)) - (*req* req) - (*ent* ent) - (*session* (bknr-request-session req)) - (*user* (bknr-request-user req)) + (*session* (bknr-request-session)) + (*user* (bknr-request-user)) (*req-var-hash* (or *req-var-hash* (make-hash-table)))) - (do-log-request req) + (do-log-request) (unwind-protect - (if (not (authorized-p handler req)) + (if (not (authorized-p handler)) (progn - (setf (session-variable :login-redirect-uri) - (redirect-uri (request-uri req))) - (redirect (website-make-path *website* "login") req)) - (if hunchentoot:*catch-errors-p* - (handle handler req) + (setf (session-value :login-redirect-uri) + (redirect-uri (request-uri))) + (redirect (website-make-path *website* "login"))) + (if *catch-errors-p* + (handle handler) (handler-bind ((error #'(lambda (e) - (with-bknr-http-response (*req* :content-type "text/html; charset=UTF-8" - :response *response-internal-server-error*) - (with-http-body (*req* *ent*) + (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 req e) + (do-error-log-request e) (error e)))) - (handle handler req)))) + (handle handler)))) (handler-case - (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files req))) + (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files))) (error (e) (warn "error ~A ignored while deleting uploaded files" e)))))) -(defmethod handle ((page-handler page-handler) req) - (funcall (page-handler-function page-handler) req)) +(defmethod handle ((page-handler page-handler)) + (funcall (page-handler-function page-handler))) + +(defvar *handlers* nil) -(defmethod publish-handler ((website website) (page-handler page-handler)) - (with-slots (content-type) page-handler - (publish :path (page-handler-prefix page-handler) - :content-type content-type - :host (website-vhosts website) - :function #'(lambda (req ent) (invoke-handler page-handler req ent) nil) - :authorizer (website-authorizer website)))) +(defun bknr-dispatch (request) + (declare (ignore request)) + (when-let ((handler (find-if #'handler-matches *handlers*))) + (curry #'invoke-handler handler))) + +(defmethod publish-handler ((website website) (handler page-handler)) + (setf *handlers* (append *handlers* (list handler)))) + +(defmethod handler-matches ((handler page-handler)) + (string-equal (page-handler-prefix handler) + (script-name))) (defclass redirect-handler (page-handler) ((to :initarg :to :reader redirect-handler-to :documentation "url to redirect to"))) -(defmethod handle ((page-handler redirect-handler) req) - (redirect (redirect-handler-to page-handler) req)) +(defmethod handle ((page-handler redirect-handler)) + (redirect (redirect-handler-to page-handler))) (defclass random-redirect-handler (redirect-handler) ()) -(defmethod handle ((page-handler random-redirect-handler) req) - (redirect (random-elt (redirect-handler-to page-handler)) req)) +(defmethod handle ((page-handler random-redirect-handler)) + (redirect (random-elt (redirect-handler-to page-handler)))) (defclass form-handler (page-handler) ()) @@ -287,39 +295,27 @@ (signal (make-condition 'form-field-missing-condition :field ',field-name)))) -(defgeneric handle-form (page-handler action req)) +(defgeneric handle-form (page-handler action)) -(defmethod handle ((page-handler form-handler) req) - (let* ((form (query-param req "action")) +(defmethod handle ((page-handler form-handler)) + (let* ((form (query-param "action")) (form-keyword (when form (make-keyword-from-string form)))) - (handle-form page-handler form-keyword req))) + (handle-form page-handler form-keyword))) (defclass prefix-handler (page-handler) ()) -(defmethod publish-handler ((website website) (page-handler prefix-handler)) - (with-slots (name content-type) page-handler - (let ((prefix (page-handler-prefix page-handler))) - (unless (eql (char prefix (1- (length prefix))) #\/) - (setf prefix (concatenate 'string prefix "/"))) - (publish-prefix :prefix prefix - :host (website-vhosts website) - :function #'(lambda (req ent) (invoke-handler page-handler req ent) nil) - :authorizer (website-authorizer website))))) +(defmethod handler-matches ((handler prefix-handler)) + (and (>= (length (script-name)) + (length (page-handler-prefix handler))) + (string-equal (page-handler-prefix handler) + (script-name) + :end2 (length (page-handler-prefix handler))))) (defclass directory-handler (prefix-handler) ((destination :initarg :destination :reader page-handler-destination))) -(defmethod publish-handler ((website website) (page-handler directory-handler)) - (with-slots (name destination) page-handler - (publish-directory :prefix (concatenate 'string (page-handler-prefix page-handler) "/") - :host (website-vhosts website) - :destination (if (pathnamep destination) - (namestring destination) - destination) - :authorizer (website-authorizer website)))) - (defclass file-handler (page-handler) ((destination :initarg :destination :reader page-handler-destination) @@ -327,68 +323,51 @@ :reader page-handler-content-type)) (:default-initargs :content-type "text/plain")) -(defmethod publish-handler ((website website) (handler file-handler)) - (with-slots (destination content-type) handler - (publish-file :path (page-handler-prefix handler) - :host (website-vhosts website) - :file (if (pathnamep destination) (namestring destination) destination) - :authorizer (website-authorizer website) - :content-type content-type))) - (defclass object-handler (prefix-handler) ((query-function :initarg :query-function :reader object-handler-query-function) (object-class :initarg :object-class :reader object-handler-object-class)) (:default-initargs :object-class t :query-function nil)) -(defgeneric object-handler-get-object (object-handler req)) -(defgeneric handle-object (object-handler object req)) - -(defmethod publish-handler ((website website) (page-handler object-handler)) - (with-slots (name content-type) page-handler - (publish :path (page-handler-prefix page-handler) - :content-type content-type - :host (website-vhosts website) - :function #'(lambda (req ent) (invoke-handler page-handler req ent) nil) - :authorizer (website-authorizer website)) - (call-next-method))) +(defgeneric object-handler-get-object (object-handler)) +(defgeneric handle-object (object-handler object)) -(defmethod object-handler-get-object ((handler object-handler) req) - (let ((id (parse-url req))) +(defmethod object-handler-get-object ((handler object-handler)) + (let ((id (parse-url))) (when id (find-store-object id :class (object-handler-object-class handler) :query-function (object-handler-query-function handler))))) -(defmethod handle ((handler object-handler) req) - (let ((object (object-handler-get-object handler req))) - (handle-object handler object req))) +(defmethod handle ((handler object-handler)) + (let ((object (object-handler-get-object handler))) + (handle-object handler object))) (defclass edit-object-handler (form-handler object-handler) ()) -(defgeneric handle-object-form (handler action object req)) +(defgeneric handle-object-form (handler action object)) -(defmethod handle-form ((handler edit-object-handler) action req) - (let ((object (object-handler-get-object handler req))) - (handle-object-form handler action object req))) +(defmethod handle-form ((handler edit-object-handler) action) + (let ((object (object-handler-get-object handler))) + (handle-object-form handler action object))) -(defmethod handle-object-form ((handler edit-object-handler) action (object (eql nil)) req) - (with-bknr-page (req :title "No such object") +(defmethod handle-object-form ((handler edit-object-handler) action (object (eql nil))) + (with-bknr-page (:title "No such object") (html "No such object, ieeeh"))) (defclass keyword-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler keyword-handler) req) - (let ((keystr (parse-url req))) +(defmethod object-handler-get-object ((handler keyword-handler)) + (let ((keystr (parse-url))) (when keystr (make-keyword-from-string keystr)))) (defclass keywords-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler keywords-handler) req) - (let ((keystr (parse-url req))) +(defmethod object-handler-get-object ((handler keywords-handler)) + (let ((keystr (parse-url))) (if keystr (mapcar #'(lambda (k) (make-keyword-from-string (string-upcase k))) (split "," keystr)) @@ -397,18 +376,18 @@ (defclass object-list-handler (object-handler) ()) -(defgeneric object-list-handler-get-objects (handler object req)) -(defgeneric object-list-handler-title (handler object req)) -(defgeneric object-list-handler-rss-link (handler object req)) +(defgeneric object-list-handler-get-objects (handler object)) +(defgeneric object-list-handler-title (handler object)) +(defgeneric object-list-handler-rss-link (handler object)) (defclass object-date-list-handler (object-list-handler) ()) -(defgeneric object-date-list-handler-grouped-objects (handler object req)) +(defgeneric object-date-list-handler-grouped-objects (handler object)) (defmethod object-date-list-handler-date ((handler object-date-list-handler object-list-handler) - object req) - (with-query-params (req date) + object) + (with-query-params (date) (get-daytime (if date (or (parse-integer date :junk-allowed t) (get-universal-time)) @@ -417,18 +396,20 @@ (defclass admin-only-handler () ()) -(defmethod authorized-p ((handler admin-only-handler) req) - (admin-p (bknr-request-user req))) +(defmethod authorized-p ((handler admin-only-handler)) + (admin-p (bknr-request-user))) (defclass xml-handler () ((style-path :initarg :style-path :reader xml-handler-style-path)) (:default-initargs :style-path nil)) -(defmethod handle :around ((handler xml-handler) req) - (with-bknr-http-response (req :content-type "text/xml") - (with-http-body (req *ent*) - (let ((sink (cxml:make-character-stream-sink *html-stream* :canonical t)) - (style-path (or (query-param req "style") +(defmethod handle :around ((handler xml-handler)) + (with-http-response (:content-type "text/xml") + (with-http-body () + (let ((sink (#-rune-is-integer cxml:make-character-stream-sink + #+rune-is-integer cxml:make-character-stream-sink/utf8 + *html-stream* :canonical t)) + (style-path (or (query-param "style") (xml-handler-style-path handler)))) (cxml:with-xml-output sink (when style-path @@ -441,44 +422,44 @@ (defclass xml-object-handler (object-handler xml-handler) ()) -(defmethod handle-object ((handler xml-object-handler) (object (eql nil)) req) +(defmethod handle-object ((handler xml-object-handler) (object (eql nil))) (error "invalid object id")) -(defgeneric xml-object-handler-show-object (handler object req)) +(defgeneric xml-object-handler-show-object (handler object)) -(defmethod xml-object-handler-show-object ((handler xml-object-handler) object req) +(defmethod xml-object-handler-show-object ((handler xml-object-handler) object) (write-to-xml object :string-rod-fn #'cxml::utf8-string-to-rod)) -(defmethod handle-object ((handler xml-object-handler) object req) - (xml-object-handler-show-object handler object req)) +(defmethod handle-object ((handler xml-object-handler) object) + (xml-object-handler-show-object handler object)) (defclass xml-object-list-handler (object-handler xml-handler) ((toplevel-element-name :initarg :toplevel-element-name :reader xml-object-list-handler-toplevel-element-name)) (:default-initargs :toplevel-element-name "objects")) -(defmethod object-handler-get-object ((handler xml-object-list-handler) req) - (multiple-value-list (parse-url req))) +(defmethod object-handler-get-object ((handler xml-object-list-handler)) + (multiple-value-list (parse-url))) -(defgeneric object-list-handler-show-object-xml (handler object req)) +(defgeneric object-list-handler-show-object-xml (handler object)) -(defmethod object-list-handler-show-object-xml ((handler xml-object-list-handler) object req) +(defmethod object-list-handler-show-object-xml ((handler xml-object-list-handler) object) #+(or) (set-string-rod-fn #'cxml::utf8-string-to-rod) (write-to-xml object)) -(defmethod handle-object ((handler xml-object-list-handler) object req) +(defmethod handle-object ((handler xml-object-list-handler) object) (let ((element-name (xml-object-list-handler-toplevel-element-name handler))) (cxml:with-element element-name - (dolist (object (object-list-handler-get-objects handler object req)) - (object-list-handler-show-object-xml handler object req))))) + (dolist (object (object-list-handler-get-objects handler object)) + (object-list-handler-show-object-xml handler object))))) (defclass blob-handler (object-handler) ()) -(defmethod handle-object ((handler blob-handler) (blob blob) req) - (with-bknr-http-response (req :content-type (blob-mime-type blob)) - (setf (request-reply-content-length req) (blob-size blob)) - (with-http-body (req *ent* :external-format '(unsigned-byte 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*)))) (defclass import-handler (form-handler) @@ -487,12 +468,12 @@ :initform *user-spool-directory-root* :reader import-handler-spool-dir))) -(defgeneric import-handler-import-pathname (handler req)) -(defgeneric import-handler-spool-files (handler req)) -(defgeneric import-handler-import-files (handler req)) +(defgeneric import-handler-import-pathname (handler)) +(defgeneric import-handler-spool-files (handler)) +(defgeneric import-handler-import-files (handler)) -(defmethod import-handler-import-pathname ((handler import-handler) req) - (let* ((user (bknr-request-user req)) +(defmethod import-handler-import-pathname ((handler import-handler)) + (let* ((user (bknr-request-user)) (spool-dir (merge-pathnames (make-pathname :directory (list :relative (user-login user))) (import-handler-spool-dir handler)))) @@ -517,7 +498,7 @@ (defmethod website-show-error-page ((website website) error) (if (website-template-handler website) - (send-error-response (website-template-handler website) *req* (princ-to-string error)) + (send-error-response (website-template-handler website) (princ-to-string error)) (html (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) (princ #\Newline *html-stream*) @@ -530,33 +511,31 @@ ((:div :class "error") (:princ-safe error))))))) -(defun show-page-with-error-handlers (fn req &key response title) - (unless response - (setf response *response-ok*)) ; can't default because used from macros and *response-ok* is not a constant - (if hunchentoot:*catch-errors-p* - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response response) - (with-http-body (req *ent*) - (website-show-page *website* fn title))) - (handler-case - (let ((body (with-output-to-string (*html-stream*) - (website-show-page *website* fn title)))) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response response) - (with-http-body (req *ent*) - (princ body *html-stream*)))) - (serious-condition (c) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response *response-internal-server-error*) - (with-http-body (req *ent*) - (website-show-error-page *website* c))))))) +(defun show-page-with-error-handlers (fn &key (response +http-ok+) title) + (setf (return-code) response) + (handler-case + (let ((body (with-output-to-string (*html-stream*) + (website-show-page *website* fn title)))) + (with-http-response (:content-type "text/html; charset=UTF-8" :response response) + (with-http-body () + (princ body *html-stream*)))) + (serious-condition (c) + (with-http-response (:content-type "text/html; charset=UTF-8" :response +http-internal-server-error+) + (with-http-body () + (website-show-error-page *website* c)))))) (defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args)) #+(or) -(defmacro with-bknr-site-template ((req &key title) &rest body) - `(with-bknr-http-response (,req :content-type "text/html") - (with-http-body (,req ,ent) +(defmacro with-bknr-site-template ((&key title) &rest body) + `((with-http-response (:content-type "text/html") + (with-http-body () (include :template "toplevel-template" :tag-body (with-output-to-string (*html-stream*) - ,@body))))) + ,@body)))))) +(defun unpublish () + (setf *dispatch-table* (remove 'bknr-handler *dispatch-table*) + *handlers* nil)) \ No newline at end of file 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 Tue Jan 29 07:19:19 2008 @@ -5,11 +5,11 @@ () (:default-initargs :query-function #'bknr.rss:find-rss-channel)) -(defmethod handle-object ((handler rss-handler) (channel (eql nil)) req) +(defmethod handle-object ((handler rss-handler) (channel (eql nil))) (error "invalid channel name")) -(defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel) req) - (with-bknr-http-response (req :content-type "text/xml; charset=UTF-8") - (with-http-body (req *ent*) +(defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel)) + (with-http-response (:content-type "text/xml; charset=UTF-8") + (with-http-body () (html (:princ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>") (bknr.rss:rss-channel-xml channel *html-stream*))))) Modified: branches/trunk-reorg/bknr/web/src/web/sessions.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/sessions.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/sessions.lisp Tue Jan 29 07:19:19 2008 @@ -1,190 +1,34 @@ (in-package :bknr.web) -(defvar *bknr-session-table-lock* (mp-make-lock "Bknr Session Table")) -(defvar *bknr-sessions* (make-hash-table :test #'equal)) - -(defvar *bknr-session-next* 1) - -(defvar *bknr-session* nil - "special variable, holds the current session for the executing thread") - (defclass bknr-session () - ((id :initarg :id :accessor bknr-session-id :initform (get-universal-time)) - (user :initarg :user :accessor bknr-session-user :initform nil) - (last-used :initform (get-universal-time) :accessor bknr-session-last-used) - (variables :initform (make-hash-table) :accessor bknr-session-variables - :documentation "Application session variables indexed by keyword (XXX flat namespace, beware)"))) - -(defun session-variable (var) - (gethash var (bknr-session-variables *session*))) - -(defun (setf session-variable) (new-value var) - (setf (gethash var (bknr-session-variables *session*)) new-value)) - -(defun make-new-session-id () - ; XXX needs to be increased in order to allow more users - (md5-string (format nil "~a.~a" (incf *bknr-session-next*) (random 200000)))) - -(defmethod initialize-instance :after ((session bknr-session) &key &allow-other-keys) - (mp-with-lock-held (*bknr-session-table-lock*) - (let ((id (make-new-session-id))) - (setf (slot-value session 'id) id) - (setf (gethash (bknr-session-id session) *bknr-sessions*) session)))) - -(defmethod close-session ((session bknr-session)) - (remhash (bknr-session-id session) *bknr-sessions*)) - -(defmethod bknr-session-touch ((session bknr-session)) - (setf (bknr-session-last-used session) (get-universal-time))) - -(defmethod bknr-session-has-user-flag ((session bknr-session) flag) - (user-has-flag (bknr-session-user session) flag)) - -(defmethod bknr-session-results-get ((session bknr-session) result-type result-query find-results-fn) - (let* ((result-name (make-keyword-from-string (string-upcase (format nil "RESULT-~A" result-type)))) - (result (gethash result-name (bknr-session-variables session)))) - (if (and result - (equal (car result) result-query)) - (cdr result) - (let ((new-results (funcall find-results-fn))) - (setf (gethash result-name (bknr-session-variables session)) (cons result-query new-results)) - new-results)))) - -(defun bknr-sessions () - (loop - for session being the hash-values of *bknr-sessions* - collect session)) - -(defparameter *http-session-timeout* 3000 - "Number of seconds after which a http session which has not been used is deleted") - -(defclass http-session (bknr-session) - ((host :initarg :host :reader http-session-host) - (event-queue :accessor http-session-event-queue) - (event-handler :accessor http-session-event-handler))) - -(defmethod print-object ((session http-session) stream) - (format stream "#<http-session id ~a user ~a host ~a>" - (bknr-session-id session) (bknr-session-user session) (http-session-host session)) - session) - -(defmethod create-event-handler ((session http-session)) - (when (slot-boundp session 'event-handler) - (error "; event handler for session already created")) - #+allegro - (let ((queue (make-instance 'mp:queue))) - (setf (http-session-event-queue session) queue) - (setf (http-session-event-handler session) (register-event-handler 'event #'(lambda (event) (mp:enqueue queue event)))))) - -#+allegro -(defmethod queued-events ((session http-session) &key wait) - (when (http-session-event-handler session) - (loop - for event = (handler-case - (mp:dequeue (http-session-event-queue session) :wait wait) - (error (e) - (declare (ignore e)) - nil)) - while event - collect event - do (setq wait nil)))) - -#+allegro -(defun serve-enable-events-request (req ent) - (let ((session (bknr-request-session req))) - (unless (slot-boundp session 'event-handler) - (create-event-handler session))) - (with-bknr-page (req :title "events enabled") - (html "events are enabled now"))) - -#+allegro -(defun serve-queued-events-request (req ent) - (with-bknr-http-response (req ent :content-type "text/xml") - (with-http-body (req ent) - (princ "<automatenEvents>" *html-stream*) - (loop - for event in (queued-events (bknr-request-session req)) - do (generate-xml-with-stream *html-stream* nil (as-xml event))) - (princ "</automatenEvents>" *html-stream*)))) - -(defvar *http-sessions* nil) -(defvar *http-sessions-lock* (mp-make-lock "HTTP Session Table")) - -(defmethod close-session ((session http-session)) + ((id :initarg :id :reader bknr-session-id :initform (get-universal-time)) + (user :initarg :user :reader bknr-session-user :initform nil) + (host :initarg :host :reader bknr-session-host :initform nil))) + +(defmethod print-object ((session bknr-session) stream) + (print-unreadable-object (session stream :type t :identity t) + (format stream "user ~A host ~A" (bknr-session-user session) (bknr-session-host session)) + session)) + +(defmethod bknr-session-user ((user (eql nil))) + nil) + +(defun bknr-request-user () + (bknr-session-user (session-value 'bknr-session))) + +(defun bknr-request-session () + (session-value 'bknr-session)) + +(defun do-log-request () + (format *debug-io* "Log: ~A~%" (request-uri)) + (return-from do-log-request) #+(or) - (when (slot-boundp session 'event-handler) - (deregister-event-handler (http-session-event-handler session))) - (mp-with-lock-held (*http-sessions-lock*) - (setf *http-sessions* (remove session *http-sessions*))) - (call-next-method)) - -(defmethod initialize-instance :after ((session http-session) &key &allow-other-keys) - (mp-with-lock-held (*http-sessions-lock*) - (format t "; new session: ~a~%" session) - (push session *http-sessions*)) - (change-slot-values (http-session-host session) 'last-seen (get-universal-time)) - (make-http-session-event session 'web-visitor-event)) - -(defun find-session (id) - (when id - (mp-with-lock-held (*http-sessions-lock*) - (find id *http-sessions* :test #'equal :key #'bknr-session-id)))) - -(defun make-http-session-event (http-session class) - (make-event class - :host (http-session-host http-session) - :session-id (bknr-session-id http-session) - :user (bknr-session-user http-session))) - -(defun drop-session (session) - (handler-case - (progn - (format t ";; dropping session ~a~%" session) - (make-http-session-event session 'web-visitor-left-event)) - (error (e) - (format t - "caught and ignored error ~a during drop-session (make-http-session-event)~%" e))) - (close-session session)) - -(defun drop-idle-sessions () - (mp-with-lock-held (*http-sessions-lock*) - (setf *http-sessions* - (loop for session in *http-sessions* - if (< *http-session-timeout* - (- (get-universal-time) (bknr-session-last-used session))) - do (drop-session session) - else collect session)))) - -#+(or) -(unless (cron-job-with-name "idle session scavenger") - (make-object 'cron-job - :minute '(0 10 20 30 40 50) - :job 'drop-idle-sessions)) - -(defclass bknr-request (http-request) - ((session :initarg :session :reader bknr-request-session))) - -(defmethod update-instance-for-different-class :before ((old http-request) - (new bknr-request) &key session) - ;; Clear parsed parameters in request. During authorization, - ;; parameters are not completely parsed in order to save time. In - ;; particular, uploaded files are only parsed after authorization. - ;; This is accomplished by clearing the cache for the parsed - ;; parameters when the session has been determined. - (setf (getf (request-reply-plist old) 'bknr-parsed-parameters) nil) - (setf (getf (request-reply-plist old) 'bknr-parsed-body-parameters) nil) - (setf (slot-value new 'session) session)) - -(defmethod bknr-request-user ((req bknr-request)) - (bknr-session-user (bknr-request-session req))) - -(defun do-log-request (req) - (let* ((session (bknr-request-session req)) + (let* ((session (bknr-request-session)) (user (bknr-session-user session)) - (host (http-session-host session)) - (url (uri-path (request-uri req))) - (referer (header-slot-value req :referer)) - (user-agent (header-slot-value req :user-agent)) + (host (bknr-session-host session)) + (url (request-uri)) + (referer (header-in :referer)) + (user-agent (header-in :user-agent)) (time (get-universal-time))) (prog1 (make-event 'web-server-log-event @@ -195,15 +39,17 @@ :user-agent user-agent :session-id (bknr-session-id session) :url url) - (format t "; ~a ~a ~a ~a~%" (format-date-time time) + (format t "; ~A ~A ~A ~A~%" (format-date-time time) (if user (user-login user) "anonymous") (host-name host) url)))) -(defun do-error-log-request (req error) - (let* ((session (bknr-request-session req)) +(defun do-error-log-request (error) + (format *debug-io* "Error: ~A~%" error) + #+(or) + (let* ((session (bknr-request-session)) (user (bknr-session-user session)) - (host (http-session-host session)) - (url (uri-path (request-uri req))) - (referer (header-slot-value req :referer)) + (host (bknr-session-host session)) + (url (request-uri)) + (referer (header-in :referer)) (time (get-universal-time))) (make-event 'web-server-error-event :time time Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Tue Jan 29 07:19:19 2008 @@ -21,10 +21,7 @@ (mapc #'emit-template-node *toplevel-children*)) (define-bknr-tag redirect-request (&key target) - (with-http-response (*req* *ent* :response *response-found*) - (set-cookie-header *req* :name "bknr-sessionid" :value (bknr-session-id (bknr-request-session *req*)) :expires :never) - (setf (reply-header-slot-value *req* :location) target) - (with-http-body (*req* *ent*)))) + (redirect target)) (define-bknr-tag select-box (name options &key (size 1) default) (html ((:select :name name :size size) @@ -141,7 +138,7 @@ <bknr:logo /> " - (html ((:img :style (css-inline :float "right") :src (website-site-logo-url *website*) :alt "logo")))) + (html ((:img :style (parenscript:css-inline :float "right") :src (website-site-logo-url *website*) :alt "logo")))) (define-bknr-tag body-style (&key background-color background-image) "Outputs the body style css definition @@ -201,7 +198,7 @@ (define-bknr-tag navi-button (&key url text) (html (:princ " ")) - (if (equal (uri-path (request-uri *req*)) + (if (equal (request-uri) url) (html (:princ-safe text)) (html (cmslink url (:princ-safe text)))) @@ -229,7 +226,7 @@ do (navi-button :url link :text name))))) (when (and (website-admin-navigation *website*) - (admin-p (bknr-request-user *req*))) + (admin-p (bknr-request-user))) (html ((:div :class "navi") "admin: " (loop @@ -258,7 +255,7 @@ (define-bknr-tag site-menu () (destructuring-bind (empty first-level &optional second-level &rest rest) - (split "/" (uri-path (request-uri *req*))) + (split "/" (request-uri)) (declare (ignore empty rest)) (html ((:div :id "navcontainer") (let ((*standard-output* *html-stream*)) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Tue Jan 29 07:19:19 2008 @@ -11,6 +11,7 @@ ;; FreeBSD "/usr/local/share/xml/catalog.ports")) +#+cmu (eval-when (:load-toplevel :execute) (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG"))) (when env-catalog @@ -63,13 +64,11 @@ collect `(set-tag-function *template-expander* (string-downcase (symbol-name ',name)) #'(lambda ,args ,body))) ,@body)) -(defgeneric initial-template-environment (expander req)) +(defgeneric initial-template-environment (expander)) -(defmethod initial-template-environment ((expander template-expander) req) - (list* (cons :request req) - (cons :entity *ent*) - (mapcar #'(lambda (foo) (cons (make-keyword-from-string (car foo)) (cdr foo))) - (all-request-params req)))) +(defmethod initial-template-environment ((expander template-expander)) + (list* (mapcar #'(lambda (foo) (cons (make-keyword-from-string (car foo)) (cdr foo))) + (all-request-params)))) (defun get-template-var (var) (cdr (assoc var *template-env*))) @@ -104,7 +103,8 @@ (defun emit-template (expander stream node env) (let* ((*template-expander* expander) (*template-env* env) - (sink (cxml:make-character-stream-sink stream :canonical nil)) + (sink (#-rune-is-integer cxml:make-character-stream-sink #+rune-is-integer cxml:make-character-stream-sink/utf8 + stream :canonical nil)) (*html-sink* (cxml:make-recoder sink #'cxml::utf8-string-to-rod))) (if (node-attribute node "suppress-xml-headers") (emit-template-node node) @@ -121,10 +121,16 @@ (defun xmls-attributes-to-sax (fn attrs) (mapcar (lambda (a) (destructuring-bind (name value) a - (sax:make-attribute :qname name - :value (funcall fn value) - :specified-p t))) - attrs)) + (if (listp name) + (destructuring-bind (qname . namespace-uri) name + (sax:make-attribute :namespace-uri namespace-uri + :qname qname + :value (funcall fn value) + :specified-p t)) + (sax:make-attribute :qname name + :value (funcall fn value) + :specified-p t)))) + attrs)) (defun emit-template-node (node) (if (stringp node) @@ -136,7 +142,8 @@ ;; XML-technisch waere es korrekter, nicht auf das Praefix zu gucken, ;; sondern auf die Namespace-URI. (cond - (ns + ((and ns + (not (find #\: ns))) (apply (find-tag-function *template-expander* name ns) (append (loop for (key name) in (remove-if #'(lambda (attr) (scan "^xmlns" (car attr))) attrs) collect (make-keyword-from-string key) @@ -170,21 +177,15 @@ (cxml:*cache-all-dtds* t) (cxml:*catalog* (template-handler-catalog handler)) (sax:*include-xmlns-attributes* t)) - ;; XXX wieder ein CMUCL quickfix - (cxml:parse-file #+allegro - template-pathname - #+cmu - (ext:unix-namestring template-pathname) - #+sbcl - (sb-int:unix-namestring template-pathname) - (cxml:make-recoder (cxml-xmls:make-xmls-builder) + (cxml:parse-file (namestring (probe-file template-pathname)) + (cxml:make-recoder (cxml-xmls:make-xmls-builder) #'cxml::rod-to-utf8-string) :validate nil))) (defmethod expand-template ((handler template-handler) - template-name &key env request) + template-name &key env) (multiple-value-bind (template-pathname args template-path) - (find-template-pathname handler template-name :request request) + (find-template-pathname handler template-name) (unless template-pathname (return-from expand-template nil)) (unless (request-variable :template-args) @@ -231,8 +232,7 @@ (when (probe-file file) (values file (cdr components))))))) -(defmethod find-template-pathname ((handler template-handler) template-name &key request) - (declare (ignore request)) +(defmethod find-template-pathname ((handler template-handler) template-name) (let ((components (remove "" (split "/" template-name) :test #'equal))) (multiple-value-bind (pathname ret-components) (find-template (template-handler-destination handler) components) @@ -257,67 +257,56 @@ (setf (gethash namestring table) cache-entry)) (cdr cache-entry))) -(defun send-error-response (handler req message &key (response-code *response-internal-server-error*)) - (let* ((pathname (find-template-pathname handler "user-error" :request req)) - (template (get-cached-template pathname handler))) - (with-bknr-http-response (req - :content-type "text/html; charset=UTF-8" - :response response-code) - (with-http-body (req *ent*) - (emit-template handler - *html-stream* - template - (acons :error-message message - (initial-template-environment - handler req))))))) +(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 () + (emit-template handler + *html-stream* + (get-cached-template (find-template-pathname handler "user-error") handler) + (acons :error-message message + (initial-template-environment + handler)))))) -(defun invoke-with-error-handlers (fn handler req) - (if hunchentoot:*catch-errors-p* - (handler-case - (funcall fn) - (template-not-found (c) - (send-error-response handler req (apply #'format - nil - (simple-condition-format-control c) - (simple-condition-format-arguments c))))) +(defun invoke-with-error-handlers (fn handler) + (if *catch-errors-p* (handler-case (funcall fn) (user-error (c) - (send-error-response handler req (apply #'format - nil - (simple-condition-format-control c) - (simple-condition-format-arguments c)) - :response-code *response-ok*)) + (send-error-response handler (apply #'format + nil + (simple-condition-format-control c) + (simple-condition-format-arguments c)) + :response-code +http-ok+)) (template-not-found (c) - (send-error-response handler req (apply #'format - nil - (simple-condition-format-control c) - (simple-condition-format-arguments c)) - :response-code *response-not-found*)) + (send-error-response handler (apply #'format + nil + (simple-condition-format-control c) + (simple-condition-format-arguments c)) + :response-code +http-not-found+)) (serious-condition (c) (warn "unexpected failure: ~A" c) - (send-error-response handler req (format nil "Internal Error:~%~%~A~%" c)))))) + (send-error-response handler (format nil "Internal Error:~%~%~A~%" c)))) + (funcall fn))) -(defmacro with-error-handlers ((handler req) &body body) - `(invoke-with-error-handlers (lambda () ,@body) ,handler ,req)) +(defmacro with-error-handlers ((handler) &body body) + `(invoke-with-error-handlers (lambda () ,@body) ,handler)) -(defmethod handle ((handler template-handler) req) - (with-error-handlers (handler req) +(defmethod handle ((handler template-handler)) + (with-error-handlers (handler) ;; Erst body ausfuehren... (let ((body (expand-template handler - (subseq (uri-path (request-uri req)) + (subseq (request-uri) (length (page-handler-prefix handler))) - :env (initial-template-environment handler req) - :request req))) + :env (initial-template-environment handler)))) ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben (if body - (with-bknr-http-response (req - :content-type "text/html; charset=UTF-8" - :response *response-ok*) - (with-http-body (req *ent*) + (with-http-response (:content-type "text/html; charset=UTF-8" + :response +http-ok+) + (with-http-body () (write-string body *html-stream*))) - (error-404 req))))) + (error-404))))) ;; XXX documentation-handler sieht interessant aus, unbedingt reparieren (defclass documentation-handler (page-handler) @@ -327,7 +316,7 @@ :initform :documentation))) #+(or) -(defmethod handle ((page-handler documentation-handler) req) +(defmethod handle ((page-handler documentation-handler)) (let ((symbol-docs (sort (loop for sym being the external-symbols in (documentation-handler-package page-handler) for documentation = (documentation sym 'function) @@ -336,7 +325,7 @@ (string-downcase (symbol-name sym))) documentation)) #'string<= :key #'car))) - (with-eboy-page (req :title "Template documentation" ) + (with-eboy-page (:title "Template documentation" ) (html "This page documents the available template processing tags. These tags can be used in .bknr files and will be dynamically expanded at page generation time. New tags can be defined by writing Modified: branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -24,24 +24,23 @@ (defclass logout-handler (page-handler) ()) -(defmethod handle ((handler logout-handler) req) - (bknr.web::drop-session (bknr-request-session req)) - (format t "url: ~A referer: ~A~%" (query-param req "url") (header-slot-value req :referer)) - (let ((url (or (query-param req "url") - (header-slot-value req :referer)))) +(defmethod handle ((handler logout-handler)) + (setf (session-value 'bknr-session) nil) + (format t "url: ~A referer: ~A~%" (query-param "url") (header-in :referer)) + (let ((url (or (query-param "url") + (header-in :referer)))) (if url - (redirect url req) - (progn (with-bknr-page (req :title "logged out") - (html (:h2 "you are logged out"))) - (change-class req 'http-request))))) + (redirect url) + (progn (with-bknr-page (:title "logged out") + (html (:h2 "you are logged out"))))))) (defclass user-handler (edit-object-handler) ((require-user-flag :initform :admin))) -(defmethod authorized-p ((handler user-handler) req) - (let* ((user (object-handler-get-object handler req)) - (web-user (bknr-request-user req)) - (action (query-param req "action")) +(defmethod authorized-p ((handler user-handler)) + (let* ((user (object-handler-get-object handler)) + (web-user (bknr-request-user)) + (action (query-param "action")) (action-keyword (when action (make-keyword-from-string action)))) (cond ((anonymous-p web-user) nil) ((admin-p web-user) t) @@ -51,14 +50,14 @@ t) (t nil)))) -(defmethod object-handler-get-object ((handler user-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler user-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'user :query-function #'find-user)))) -(defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req) - (with-bknr-page (req :title "Manage users") +(defmethod handle-object-form ((handler user-handler) action (user (eql nil))) + (with-bknr-page (:title "Manage users") ((:table :border "1") (:tr (:th "Login") (:th "Real name") @@ -77,20 +76,20 @@ (:h2 "Create new user") (user-form))) -(defmethod handle-object-form ((handler user-handler) action (user user) req) - (with-bknr-page (req :title #?"$((class-name (class-of user))) $((user-login user))") +(defmethod handle-object-form ((handler user-handler) action (user user)) + (with-bknr-page (:title #?"$((class-name (class-of user))) $((user-login user))") #+(or) (bknr.images:user-image :user (user-login user)) (user-form :user-id (store-object-id user)))) -(defmethod handle-object-form ((handler user-handler) (action (eql :search)) user req) - (with-query-params (req login) - (redirect (format nil "/user/~A" login) req))) +(defmethod handle-object-form ((handler user-handler) (action (eql :search)) user) + (with-query-params (login) + (redirect (format nil "/user/~A" login)))) -(defmethod handle-object-form ((handler user-handler) (action (eql :save)) user req) +(defmethod handle-object-form ((handler user-handler) (action (eql :save)) user) (unless user - (setf user (bknr-request-user req))) + (setf user (bknr-request-user))) (when user - (with-query-params (req password password-repeat + (with-query-params (password password-repeat full-name (email (error "must provide email address"))) (when (not (equal password password-repeat)) @@ -99,9 +98,9 @@ (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name))) - (when (admin-p (bknr-request-user req)) + (when (admin-p (bknr-request-user)) (let* ((all-flags (all-user-flags)) - (set-flags (keywords-from-query-param-list (query-param-list req "flags"))) + (set-flags (keywords-from-query-param-list (query-param-list "flags"))) (unset-flags (set-difference all-flags set-flags))) (user-add-flags user set-flags) (user-remove-flags user unset-flags))) @@ -112,26 +111,26 @@ () (:report "You are not authorized to perform this operation")) -(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req) - (unless (admin-p (bknr-request-user req)) +(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user) + (unless (admin-p (bknr-request-user)) (error 'unauthorized-error)) (when user (delete-user user)) - (redirect "/user" req)) + (redirect "/user")) -(defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req) - (with-query-params (req login email full-name password password-repeat) +(defmethod handle-object-form ((handler user-handler) (action (eql :create)) user) + (with-query-params (login email full-name password password-repeat) (if (and password (not (equal password password-repeat))) (error "please enter the same password twice") (if login - (let* ((flags (keywords-from-query-param-list (query-param-list req "keyword"))) + (let* ((flags (keywords-from-query-param-list (query-param-list "keyword"))) (user (make-user login :email email :full-name full-name :password password :flags flags))) - (redirect (edit-object-url user) req)) + (redirect (edit-object-url user))) (error "please enter a login"))))) (define-bknr-webserver-module user 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 Tue Jan 29 07:19:19 2008 @@ -7,8 +7,6 @@ (defvar *website-modules* (make-hash-table :test #'equal)) -(defvar *req* nil "Current request") -(defvar *ent* nil "Current entity") (defvar *session* nil "Current session") (defvar *user* nil "Current user") (defvar *req-var-hash* nil "Request variables") @@ -16,67 +14,57 @@ (defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args)) -(defmacro with-cookies ((request &rest names) &rest body) - (let ((cookies (gensym))) - `(let ((,cookies (get-cookie-values ,request))) - (let ,(mapcar #'(lambda (name) - `(,name (cookie-value ,cookies ,(symbol-name name)))) - names) - ,@body)))) +(defmacro with-cookies ((&rest names) &rest body) + `(let ,(mapcar #'(lambda (name) + `(,name (cookie-in ,(symbol-name name)))) + names) + ,@body)) -(defmacro with-query-params ((request &rest params) &rest body) +(defmacro with-query-params ((&rest params) &rest body) (let ((vars (loop for param in params when (and (symbolp param) (not (null param))) - collect (list param `(query-param ,request ,(symbol-name param))) + collect (list param `(get-parameter ,(symbol-name param))) when (consp param) collect (list (car param) - `(or (query-param ,request ,(symbol-name (car param))) + `(or (get-parameter ,(symbol-name (car param))) ,(second param)))))) (if vars `(let ,vars ,@body) (first body)))) -(defmacro form-case (request &rest cases) +(defmacro form-case (&rest cases) `(cond ,@(mapcar #'(lambda (c) (if (eql (car c) t) `(t ,@(cdr c)) - `((query-param ,request ,(symbol-name (car c))) - (with-query-params (,request ,@(cadr c)) + `((get-parameter ,(symbol-name (car c))) + (with-query-params (,@(cadr c)) ,@(cddr c))))) cases))) -#+(or) -(form-case req - (import (keyword1 keyword2 keyword3 keyword4) - (list 'bla 'blob)) - (t (format nil "foo~%"))) - -#+nil -(defmacro with-bknr-session ((req) &rest body) - `(let* ((*req* ,req) - (*session* (bknr-request-session *req*)) - (*user* (bknr-session-user *session*))) +(defmacro with-http-response ((&key (content-type "text/html") (response +http-ok+)) &rest body) + `(progn + (setf (content-type) ,content-type) + (setf (return-code) ,response) ,@body)) -(defmacro with-bknr-http-response ((req &rest args) &rest body) - `(with-http-response (,req *ent* ,@args) - (if (subtypep (type-of ,req) 'bknr-request) - (set-cookie-header ,req :name "bknr-sessionid" :value (bknr-session-id (bknr-request-session ,req)) :expires :never) - (warn "; not a bknr-request ~a within with-bknr-http-response~%" ,req)) +(defvar *html-stream*) + +(defmacro with-http-body ((&key external-format) &body body) + `(with-output-to-string (*html-stream*) ,@body)) -(defmacro with-image-from-uri ((image-variable *req* *ent* prefix) &rest body) +(defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (uri-path (request-uri ,*req*))) + (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (request-uri)) (unless match - (http-error ,*req* ,*ent* *response-bad-request* "bad request - missing image path or loid")) + (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 ,*req* ,*ent* *response-not-found* "image not found")) + (http-error +http-not-found+ "image not found")) ,@body))) (defmacro define-bknr-tag (name (&rest args) &rest 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 Tue Jan 29 07:19:19 2008 @@ -11,22 +11,18 @@ (defparameter *upload-file-size-limit* 5000000) -(defun error-404 (req) - (with-bknr-http-response (req :response *response-not-found*) - (with-http-body (req *ent*) +(defun error-404 () + (with-http-response (:response +http-not-found+) + (with-http-body () (html "The page you requested could not be found.")))) -(defun redirect (to req) - (with-bknr-http-response (req :response *response-found*) - (setf (reply-header-slot-value req :location) to) - (with-http-body (req *ent*)))) - (defun redirect-uri (uri) (make-instance 'uri :path (uri-path uri) :query (uri-query uri))) -(defun get-multipart-form-data (request) - (unless (getf (request-reply-plist request) 'multipart-parsed) +#+(or) +(defun get-multipart-form-data () + (unless (aux-request-value 'multipart-parsed) (let (parameters uploaded-files file-size-limit-reached) @@ -60,82 +56,72 @@ (get-all-multipart-data request :limit *upload-file-size-limit*))))) (when file-size-limit-reached (error "upload file size limit exceeded")) - (setf (getf (request-reply-plist request) 'bknr-parsed-body-parameters) parameters) - (setf (getf (request-reply-plist request) 'uploaded-files) uploaded-files)))) + (setf (aux-request-value 'bknr-parsed-body-parameters) parameters) + (setf (aux-request-value 'uploaded-files) uploaded-files)))) -(defun get-urlencoded-form-data (request) - (loop for name-value in (form-urlencoded-to-query (get-request-body request)) - do (push name-value (getf (request-reply-plist request) 'bknr-parsed-body-parameters)))) +(defun get-urlencoded-form-data () + (format t "get-urlencoded-form-data not ported~%") + #+(or) + (loop for name-value in (form-urlencoded-to-query (get-request-body)) + do (push name-value (aux-request-value 'bknr-parsed-body-parameters)))) -(defun parse-request-body (request &key uploads) - (let ((content-type (header-slot-value request :content-type))) +(defun parse-request-body (&key uploads) + (let ((content-type (header-in :content-type))) (cond ((null content-type) nil) ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) + (format t "body parameters not parsed~%") + #+(or) (get-urlencoded-form-data request)) ((and uploads (scan #?r"^(?i)multipart/form-data" content-type)) - (get-multipart-form-data request))))) - -(defgeneric get-parameters-from-body (request) - (:documentation "Generic function to read in the parameters of a -request. This is a generic function because unauthorized request -bodies must not be completely read as that is done in the request -authorization phase. In this phase, processing must be fast and may -not return errors due to exceeded upload file size limits.")) - -(defmethod get-parameters-from-body ((request http-request)) - (parse-request-body request :uploads nil)) - -(defmethod get-parameters-from-body ((request bknr-request)) - (unless (getf (request-reply-plist request) 'body-parsed) - (setf (getf (request-reply-plist request) 'bknr-parsed-body-parameters) nil) - (parse-request-body request :uploads t) - (setf (getf (request-reply-plist request) 'body-parsed) t))) + (format t "uploads not read~%") + #+(or) + (get-multipart-form-data))))) -(defun request-uploaded-files (request &key all-info) +(defun request-uploaded-files (&key all-info) "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user. If :all-info is non-nil, the full upload file information is returned as a list" - (get-parameters-from-body request) + (format t "request-uploaded-files not yet ported~%") (if all-info - (getf (request-reply-plist request) 'uploaded-files) + (aux-request-value 'uploaded-files) (mapcar (lambda (upload) (cons (upload-name upload) (upload-pathname upload))) - (getf (request-reply-plist request) 'uploaded-files)))) + (aux-request-value 'uploaded-files)))) -(defun request-uploaded-file (request parameter-name) - (cdr (find parameter-name (request-uploaded-files request) :test #'equal :key #'car))) +(defun request-uploaded-file (parameter-name) + (cdr (find parameter-name (request-uploaded-files) :test #'equal :key #'car))) -(defun all-request-params (request) +(defun all-request-params () "Return all non-empty request parameters - This includes all parameters encoded in the URL as well as those in the request body, either as urlencoded strings or as multipart body. If a multipart body is present in the request, any uploaded files are saved in a temporary file and noted in the -request's plist. Uploaded files will be automatically deleted by the with-bknr-http-response +request's plist. Uploaded files will be automatically deleted by the with-http-response macro after the request body has been executed." - (unless (getf (request-reply-plist request) 'bknr-parsed-parameters) - (let ((request-charset (or (register-groups-bind (charset) (#?r".*charset=\"?([^\"; ]+).*" (header-slot-value request :content-type)) charset) + (unless (aux-request-value 'bknr-parsed-parameters) + (let ((request-charset (or (register-groups-bind (charset) (#?r".*charset=\"?([^\"; ]+).*" (header-in :content-type)) charset) "utf-8"))) - (get-parameters-from-body request) - (setf (getf (request-reply-plist request) 'bknr-parsed-parameters) + (declare (ignore request-charset)) + (format t "post parameters not read~%") + #+(or) + (setf (aux-request-value 'bknr-parsed-parameters) (mapcar (lambda (param) (cons (car param) (iconv:iconv request-charset "utf-8" (cdr param)))) - (remove "" (append (form-urlencoded-to-query (uri-query (request-uri request))) - (getf (request-reply-plist request) 'bknr-parsed-body-parameters)) + (remove "" (append (form-urlencoded-to-query (uri-query (request-uri))) + (aux-request-value 'bknr-parsed-body-parameters)) :key #'cdr :test #'string-equal))))) - (getf (request-reply-plist request) 'bknr-parsed-parameters)) + (aux-request-value 'bknr-parsed-parameters)) -(defun query-param (request param-name) - (let ((value (cdr (assoc param-name (all-request-params request) :test #'string-equal)))) +(defun query-param (param-name) + (let ((value (cdr (assoc param-name (all-request-params) :test #'string-equal)))) (when (equal "" value) (setf value nil)) value)) -(defun query-param-list (request param-name) - (assoc-values param-name (request-query request) :test #'string-equal)) - -(defun cookie-value (cookies param) - (cdr (assoc param cookies :test #'string-equal))) +(defun query-param-list (param-name) + (format *debug-io* "questionable: query-param-list~%") + (assoc-values param-name (request-query) :test #'string-equal)) (defun request-variable (var) (gethash var *req-var-hash*)) @@ -148,8 +134,8 @@ collect key collect (request-variable key))) -(defun http-error (req response message) - (with-bknr-page (req :title #?"error: $(message)" :response response) +(defun http-error (response message) + (with-bknr-page (:title #?"error: $(message)" :response response) (:princ-safe message)) (finish-output *html-stream*) (error message)) @@ -170,17 +156,17 @@ (#\< "<") (#\> ">"))))) -(defun parse-url (req) - (values-list (cddr (mapcar #'uridecode-string (split "/" (uri-path (request-uri req))))))) +(defun parse-url () + (values-list (cddr (mapcar #'url-decode (split "/" (request-uri)))))) -(defun last-url-component (req) +(defun last-url-component () (register-groups-bind (last) - ("/([^\\/]+)$" (uri-path (request-uri req))) + ("/([^\\/]+)$" (request-uri)) last)) -(defun parse-date-field (name req) +(defun parse-date-field (name) (let ((timespec (mapcar #'(lambda (var) (parse-integer - (query-param req (concatenate 'string name "-" var)) + (get-parameter (concatenate 'string name "-" var)) :junk-allowed t)) '("minute" "hour" "day" "month" "year")))) (unless (car timespec) @@ -191,15 +177,15 @@ (apply #'encode-universal-time 0 timespec) nil))) -(defun bknr-url-path (handler req) +(defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" (let ((len (length (page-handler-prefix handler)))) - (subseq (uri-path (request-uri req)) len))) + (subseq (request-uri) len))) -(defun self-url (req &key command prefix) +(defun self-url (&key command prefix) (destructuring-bind (empty old-prefix object-id &rest old-command) - (split "/" (uri-path (request-uri req))) + (split "/" (request-uri)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))")) @@ -293,4 +279,4 @@ (princ " />")))) (defun encode-urlencoded (string) - (url-encode string)) \ No newline at end of file +(regex-replace-all #?r"\+" (url-encode string) "%20")) Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/m2.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/m2.lisp Tue Jan 29 07:19:19 2008 @@ -352,6 +352,9 @@ retval)) (defun string-safe (string) + (format t "check encoding of sponsor name~%") + (or string "") + #+(or) (if string (escape-nl (with-output-to-string (s) (net.html.generator::emit-safe s string))) Modified: branches/trunk-reorg/projects/bos/m2/mail-generator.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/mail-generator.lisp Tue Jan 29 07:19:19 2008 @@ -226,8 +226,8 @@ (unless (contract-download-only-p contract) (delete-file (contract-pdf-pathname contract :print t)))) -(defun mail-backoffice-sponsor-data (contract req) - (with-query-params (req numsqm country email name address date language) +(defun mail-backoffice-sponsor-data (contract) + (with-query-params (numsqm country email name address date language) (let ((parts (list (make-html-part (format nil " <html> <body> @@ -246,7 +246,7 @@ name address email)) - (make-contract-xml-part (store-object-id contract) (all-request-params req)) + (make-contract-xml-part (store-object-id contract) (all-request-params)) (make-vcard-part (store-object-id contract) (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) :note (format nil "Paid-by: Back office @@ -264,8 +264,8 @@ :email email))))) (mail-contract-data contract "Manually entered sponsor" parts)))) -(defun mail-manual-sponsor-data (req) - (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly) +(defun mail-manual-sponsor-data () + (with-query-params (contract-id vorname name strasse plz ort email telefon donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (sponsor-id (store-object-id (contract-sponsor contract))) (parts (list (make-html-part (format nil " @@ -296,7 +296,7 @@ vorname name strasse plz ort email telefon (if donationcert-yearly "ja" "nein") *website-url* contract-id email)) - (make-contract-xml-part contract-id (all-request-params req)) + (make-contract-xml-part contract-id (all-request-params)) (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id :note (format nil "Paid-by: Manual money transfer Contract ID: ~A @@ -331,8 +331,8 @@ (remhash contract-id *worldpay-params-hash*)) (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) -(defun mail-worldpay-sponsor-data (req) - (with-query-params (req contract-id) +(defun mail-worldpay-sponsor-data () + (with-query-params (contract-id) (let* ((contract (store-object-with-id (parse-integer contract-id))) (params (get-worldpay-params contract-id)) (parts (list (make-html-part (format nil " Modified: branches/trunk-reorg/projects/bos/web/package.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/package.lisp (original) +++ branches/trunk-reorg/projects/bos/web/package.lisp Tue Jan 29 07:19:19 2008 @@ -1,4 +1,4 @@ (in-package :cl-user) (defpackage :bos.web - (:use :cl :net.aserve :net.html.generator)) + (:use :cl :hunchentoot :xhtml-generator)) Modified: branches/trunk-reorg/projects/bos/web/web.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/web.lisp (original) +++ branches/trunk-reorg/projects/bos/web/web.lisp Tue Jan 29 07:19:19 2008 @@ -36,6 +36,8 @@ :worldpay-test-mode *worldpay-test-mode*) (format t "~&; Starting aserve~@[ in debug mode~].~%" debug) (force-output) + (format t "Hunchentoot startup not implemented~%") + #+(or) (setq *webserver* (if debug (progn (net.aserve::debug-on :notrap) Modified: branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/allocation-area-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,7 +6,7 @@ (defclass allocation-area-handler (admin-only-handler edit-object-handler) ()) -(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil)) req) +(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil))) (with-bos-cms-page (req :title "Allocation Areas") (html (:h2 "Defined allocation areas") @@ -27,7 +27,7 @@ (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%"))))) (:p (cmslink "create-allocation-area" "Create new allocation area"))))) -(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area req) +(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area) (with-bos-cms-page (req :title "Allocation Area") (with-slots (active-p left top width height) allocation-area (html @@ -75,7 +75,7 @@ do (html (:td ((:a :href #?"/enlarge-overview/$(tile-x)/$(tile-y)") ((:img :width "90" :height "90" :border "0" :src #?"/overview/$(tile-x)/$(tile-y)")))))))))))))) -(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area req) +(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area) (delete-object allocation-area) (with-bos-cms-page (req :title "Allocation area has been deleted") (:h2 "The allocation area has been deleted"))) @@ -83,7 +83,7 @@ (defclass allocation-area-gfx-handler (admin-only-handler object-handler) ()) -(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req) +(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area) (cl-gd:with-image* ((allocation-area-width allocation-area) (allocation-area-height allocation-area) t) (with-slots (left top width height) allocation-area @@ -123,13 +123,13 @@ do (incf dest-x copy-width)) do (incf dest-y copy-height)) (cl-gd:draw-polygon vertices :color (elt colors 1)) - (emit-image-to-browser req cl-gd:*default-image* :png))))) + (emit-image-to-browser cl-gd:*default-image* :png))))) (defclass create-allocation-area-handler (admin-only-handler form-handler) ()) -(defmethod handle-form ((handler create-allocation-area-handler) action req) - (with-query-params (req x y left top) +(defmethod handle-form ((handler create-allocation-area-handler) action) + (with-query-params (x y left top) (cond ((and x y left top) (destructuring-bind (x y left top) (mapcar #'parse-integer (list x y left top)) @@ -140,15 +140,15 @@ (:h2 "Choose upper left corner first, then lower-right corner")) (redirect (format nil "/allocation-area/~D" (store-object-id (make-allocation-rectangle left top (- x left) (- y top)))) - req)))) + )))) ((and x y) (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" x y (uriencode-string "Choose lower right point of allocation area") (uriencode-string (format nil "~A?left=~A&top=~A&" - (uri-path (request-uri req)) + (uri-path (request-uri)) x y))) - req)) + )) (t (with-bos-cms-page (req :title "Create allocation area") ((:form :method "POST" :enctype "multipart/form-data")) @@ -163,16 +163,16 @@ (:tr (:td "Start-Y") (:td (text-field "start-y" :value 0 :size 5))) (:tr (:td (submit-button "rectangle" "rectangle"))))))))) -(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle)) req) - (with-query-params (req start-x start-y) +(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle))) + (with-query-params (start-x start-y) (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" start-x start-y (uriencode-string "Choose upper left point of allocation area") - (uriencode-string (format nil "~A?" (uri-path (request-uri req))))) - req))) + (uriencode-string (format nil "~A?" (uri-path (request-uri))))) + ))) -(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)) req) - (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files req) :test #'equal :key #'car)))) +(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) + (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car)))) (cond ((not uploaded-text-file) (with-bos-cms-page (req :title "No Text file uploaded") Modified: branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,19 +6,19 @@ (defvar *xml-sink*) (defmacro with-xml-response (req &body body) - `(with-http-response (,req *ent* :content-type "text/xml") + `((with-http-response (:content-type "text/xml") (with-query-params (,req download) (when download (setf (reply-header-slot-value ,req :content-disposition) (format nil "attachment; filename=~A" download)))) - (with-http-body (,req *ent*) - (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) + (with-http-body () + (let ((*xml-sink* (make-character-stream-sink *html-stream* :canonical nil))) (with-xml-output *xml-sink* (with-element "response" ,@body)))))) (defmacro with-xml-error-handler (req &body body) - (declare (ignore req)) + (declare (ignore)) `(handler-case (progn ,@body) (error (e) @@ -30,8 +30,8 @@ (defclass boi-handler (page-handler) ()) -(defmethod authorized-p ((handler boi-handler) req) - (let ((user (bknr-request-user req))) +(defmethod authorized-p ((handler boi-handler)) + (let ((user (bknr-request-user))) (or (admin-p user) (user-has-flag user :boi)))) @@ -46,9 +46,9 @@ (error "Invalid sponsor ID (wrong type)")) sponsor)) -(defmethod handle ((handler create-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req num-sqm country sponsor-id name paid expires) +(defmethod handle ((handler create-contract-handler)) + (with-xml-error-handler () + (with-query-params (num-sqm country sponsor-id name paid expires) (setf num-sqm (ignore-errors (parse-integer num-sqm :junk-allowed t))) (unless num-sqm (error "missing or invalid num-sqm parameter")) @@ -79,9 +79,9 @@ (defclass pay-contract-handler (boi-handler) ()) -(defmethod handle ((handler pay-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req contract-id name) +(defmethod handle ((handler pay-contract-handler)) + (with-xml-error-handler () + (with-query-params (contract-id name) (unless contract-id (error "missing contract-id parameter")) (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id)) @@ -91,7 +91,7 @@ (with-transaction (:contract-paid) (contract-set-paidp contract (format nil "~A: manually set paid by ~A" (format-date-time) - (user-login (bknr-request-user req)))) + (user-login (bknr-request-user)))) (when name (setf (user-full-name (contract-sponsor contract)) name)))) (with-xml-response () @@ -103,9 +103,9 @@ (defclass cancel-contract-handler (boi-handler) ()) -(defmethod handle ((handler cancel-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req contract-id) +(defmethod handle ((handler cancel-contract-handler)) + (with-xml-error-handler () + (with-query-params (contract-id) (unless contract-id (error "missing contract-id parameter")) (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id)) Modified: branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/contract-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,7 +9,7 @@ (defparameter *show-m2s* 5) -(defmethod handle-object ((handler contract-handler) contract req) +(defmethod handle-object ((handler contract-handler) contract) (with-bos-cms-page (req :title "Displaying contract details") ((:table :border "0") (:tr (:td "sponsor") Modified: branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/contract-image-handler.lisp Tue Jan 29 07:19:19 2008 @@ -7,7 +7,7 @@ () (:default-initargs :class 'contract)) -(defmethod handle-object ((handler contract-image-handler) contract req) +(defmethod handle-object ((handler contract-image-handler) contract) "Create and return a GD image of the contract. The returned rectangular image will have the size of the contracts' bounding box. All square meters will have yellow color, the background will be transparent." @@ -17,7 +17,7 @@ ;; We manipulate pixels in a temporary array which is copied to the GD image as ;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels. (let ((work-array (make-array (list width height) :element-type 'fixnum :initial-element 0)) - (color (parse-color (or (second (decoded-handler-path handler req)) "ffff00")))) + (color (parse-color (or (second (decoded-handler-path handler)) "ffff00")))) (flet ((set-pixel (x y) (decf x left) (decf y top) @@ -27,4 +27,4 @@ (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) (setf (cl-gd:raw-pixel) (aref work-array x y))))) - (emit-image-to-browser req cl-gd:*default-image* :png :cache-sticky t)))) \ No newline at end of file + (emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t)))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/languages-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,11 +5,11 @@ (defclass languages-handler (admin-only-handler form-handler) ()) -(defmethod handle-form ((handler languages-handler) action req) +(defmethod handle-form ((handler languages-handler) action) (with-bos-cms-page (req :title "Languages") (case action (:add (handler-case - (with-query-params (req code name) + (with-query-params (code name) (when (and code name) (make-object 'website-language :code code :name name) (html (:h2 "Language " (:princ-safe code) " (" (:princ-safe name) ") created")))) @@ -17,7 +17,7 @@ (html (:h2 "Error creating language") (:pre (:princ-safe e)))))) (:delete (handler-case - (with-query-params (req delete-code) + (with-query-params (delete-code) (when delete-code (delete-object (language-with-code delete-code)) (html (:h2 "Language " (:princ-safe delete-code) " deleted")))) Modified: branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/map-browser-handler.lisp Tue Jan 29 07:19:19 2008 @@ -18,7 +18,7 @@ (defclass map-browser-handler (prefix-handler) ()) -(defun decode-coords-in-handler-path (handler req) +(defun decode-coords-in-handler-path (handler) (labels ((ensure-valid-coordinates (x y) (setq x (parse-integer x)) (setq y (parse-integer y)) @@ -30,29 +30,29 @@ (<= 0 y 10800)) (error "invalid coordinates ~A/~A" x y)) (list x y))) - (with-query-params (req xcoord ycoord) + (with-query-params (xcoord ycoord) (when (and xcoord ycoord) (return-from decode-coords-in-handler-path (ensure-valid-coordinates xcoord ycoord)))) - (let ((handler-arguments (decoded-handler-path handler req))) + (let ((handler-arguments (decoded-handler-path handler))) (when (and handler-arguments (< 1 (length handler-arguments))) (apply #'ensure-valid-coordinates handler-arguments))))) -(defmethod handle ((handler map-browser-handler) req) - (with-query-params (req chosen-url) +(defmethod handle ((handler map-browser-handler)) + (with-query-params (chosen-url) (when chosen-url (setf (session-variable :chosen-url) chosen-url))) - (with-query-params (req view-x view-y) - (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string req) - (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler req) - (with-query-params (req action) + (with-query-params (view-x view-y) + (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) + (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler) + (with-query-params (action) (when (equal action "save") (if (session-variable :chosen-url) (redirect (format nil "~Ax=~D&y=~D" (session-variable :chosen-url) point-x point-y) - req) + ) (with-bos-cms-page (req :title "Map Point Chooser") (html (:princ-safe "You chose " point-x " / " point-y)))) (return-from handle t))) @@ -71,14 +71,14 @@ (click-coord-y (+ (tile-nw-y start-tile) click-y))) (setq point-x click-coord-x point-y click-coord-y) - (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y) req) + (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y)) (return-from handle t))) (cond ((and click-y (not point-y)) - (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)) req)) + (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)))) (point-y (with-bos-cms-page (req :title "Map Point Chooser") - (with-query-params (req heading) + (with-query-params (heading) (when heading (html (:h2 (:princ-safe heading))))) (html @@ -131,7 +131,7 @@ ((:div :id "cursor" :style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible") ((:img :src "/images/map-cursor.png"))))))) - (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) + (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) (t (with-bos-cms-page (req :title "Map Point Chooser") (html Modified: branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/map-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -34,7 +34,7 @@ (:tr (:td "Y:") (:td (text-field "ycoord" :size "5" :value y))) (:tr ))) (:td - (with-query-params (req background areas contracts) + (with-query-params (background areas contracts) ;; xxx should use tile-layers (unless (or background areas contracts) (setq background t @@ -52,15 +52,15 @@ (defclass image-tile-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler image-tile-handler) req) - (destructuring-bind (x y &rest operations) (decoded-handler-path handler req) +(defmethod object-handler-get-object ((handler image-tile-handler)) + (destructuring-bind (x y &rest operations) (decoded-handler-path handler) (declare (ignore operations)) (setf x (parse-integer x)) (setf y (parse-integer y)) (ensure-map-tile x y))) -(defmethod handle-object ((handler image-tile-handler) (tile (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((handler image-tile-handler) (tile (eql nil))) + (error-404)) (defun parse-operations (&rest operation-strings) (mapcar #'(lambda (operation-string) @@ -68,46 +68,48 @@ (apply #'list (make-keyword-from-string operation) arguments))) operation-strings)) -(defmethod handle-object ((handler image-tile-handler) tile req) +(defmethod handle-object ((handler image-tile-handler) tile) ;; xxx parse url another time - the parse result of ;; object-handler-get-object should really be kept in the request - (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler req) + (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) (declare (ignore x y)) (let ((changed-time (image-tile-changed-time tile)) - (ims (header-slot-value req :if-modified-since))) + (ims (header-in :if-modified-since))) + (format t "ims for hunchentoot not implemented~%") + #+(or) (setf (net.aserve::last-modified *ent*) changed-time) #+(or) (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) (if (or (not ims) (> changed-time (date-to-universal-time ims))) (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) - (emit-image-to-browser req image :png + (emit-image-to-browser image :png :date changed-time :max-age 60) (cl-gd:destroy-image image)) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () ; do nothing )))))) (defclass enlarge-tile-handler (image-tile-handler) ()) -(defun tile-active-layers-from-request-params (tile req) +(defun tile-active-layers-from-request-params (tile) (let (active-layers (all-layer-names (mapcar #'symbol-name (image-tile-layers tile)))) (dolist (layer-name all-layer-names) - (when (query-param req layer-name) + (when (query-param layer-name) (push layer-name active-layers))) (or (reverse active-layers) all-layer-names))) -(defun tile-url (tile x y req) +(defun tile-url (tile x y) (format nil "/overview/~D/~D~(~{/~A~}~)" x y - (tile-active-layers-from-request-params tile req))) + (tile-active-layers-from-request-params tile))) -(defmethod handle-object ((handler enlarge-tile-handler) tile req) - (let ((ismap-coords (decode-ismap-query-string req)) +(defmethod handle-object ((handler enlarge-tile-handler) tile) + (let ((ismap-coords (decode-ismap-query-string)) (tile-x (tile-nw-x tile)) (tile-y (tile-nw-y tile))) (if ismap-coords @@ -116,10 +118,10 @@ (m2 (get-m2 x y)) (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) (if contract-id - (redirect #?"/contract/$(contract-id)" req) + (redirect #?"/contract/$(contract-id)") (with-bos-cms-page (req :title "Not sold") (html (:h2 "this square meter has not been sold yet"))))) (with-bos-cms-page (req :title "Browsing tile") - (:a ((:a :href (uri-path (request-uri req))) - ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) - (map-navigator req tile-x tile-y "/enlarge-overview/"))))) \ No newline at end of file + (:a ((:a :href (uri-path (request-uri))) + ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y))))) + (map-navigator tile-x tile-y "/enlarge-overview/"))))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/news-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -9,10 +9,10 @@ (defclass edit-news-handler (admin-only-handler edit-object-handler) ()) -(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) +(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil))) (let ((language (session-variable :language))) (with-bos-cms-page (req :title "Choose news item to edit") - (content-language-chooser req) + (content-language-chooser) (if (all-news-items) (html (:h2 "Choose existing news item") @@ -28,13 +28,13 @@ ((:form :method "post") (submit-button "new" "new"))))) -(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req) - (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req)) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil))) + (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))))) -(defmethod handle-object-form ((handler edit-news-handler) action news-item req) +(defmethod handle-object-form ((handler edit-news-handler) action news-item) (let ((language (session-variable :language))) (with-bos-cms-page (req :title "Edit news item") - (content-language-chooser req) + (content-language-chooser) ((:script :type "text/javascript") "tinyMCE.init({ mode : 'textareas', theme : 'advanced' });") ((:form :method "post") @@ -47,15 +47,15 @@ :value (news-item-text news-item language)))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?")))))))) -(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item req) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item) (let ((language (session-variable :language))) - (with-query-params (req title text) + (with-query-params (title text) (update-news-item news-item language :title title :text text) (with-bos-cms-page (req :title "News item updated") (:h2 "Your changes have been saved") "You may " (cmslink (edit-object-url news-item) "continue editing the news item"))))) -(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item req) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item) (delete-object news-item) (with-bos-cms-page (req :title "News item has been deleted") (:h2 "The news item has been deleted"))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/packages.lisp Tue Jan 29 07:19:19 2008 @@ -8,12 +8,11 @@ :cl-user :cl-interpol :cl-ppcre - :net.aserve - :net.aserve.client + :hunchentoot :xhtml-generator :cxml :puri - #+(or) :mime + :cl-mime :acl-compat.socket :bknr.web :bknr.datastore @@ -27,5 +26,4 @@ :bos.m2.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) (:export)) Modified: branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/poi-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,8 +6,8 @@ (defclass make-poi-handler (page-handler) ()) -(defmethod handle ((handler make-poi-handler) req) - (with-query-params (req name) +(defmethod handle ((handler make-poi-handler)) + (with-query-params (name) (cond ((find-store-object name :class 'poi) (with-bos-cms-page (req :title "Duplicate POI name") @@ -18,13 +18,13 @@ (html (:h2 "Bad technical name") "Please use only alphanumerical characters, - and _ for technical POI names"))) (t - (redirect (edit-object-url (make-poi (session-variable :language) name)) req))))) + (redirect (edit-object-url (make-poi (session-variable :language) name))))))) (defclass edit-poi-handler (admin-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) -(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)) req) +(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil))) (with-bos-cms-page (req :title "Choose POI") (if (store-objects-with-class 'poi) (html @@ -50,8 +50,8 @@ (html ((:img :src #?"/images/$(icon).gif"))))) (defmethod handle-object-form ((handler edit-poi-handler) - action (poi poi) req) - (with-query-params (req language shift shift-by) + action (poi poi)) + (with-query-params (language shift shift-by) (unless language (setq language (session-variable :language))) (when shift ;; change image order @@ -67,7 +67,7 @@ (change-slot-values poi 'bos.m2::images new-images))) (setf (session-variable :language) language) (with-bos-cms-page (req :title "Edit POI") - (content-language-chooser req) + (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 " @@ -95,11 +95,11 @@ (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" (first (poi-area poi)) (second (poi-area poi)) - (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) + (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri))))) "[relocate]")) (t (cmslink (format nil "map-browser/?chosen-url=~A" - (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) + (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri))))) "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) @@ -167,8 +167,8 @@ (submit-button "delete" "delete" :confirm "Really delete the POI?")))))))) (defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :save)) (poi poi) req) - (with-query-params (req published title subtitle description language x y icon movie) + (action (eql :save)) (poi poi)) + (with-query-params (published title subtitle description language x y icon movie) (unless language (setq language (session-variable :language))) (let ((args (list :title title :published published @@ -187,8 +187,8 @@ (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-airal)) (poi poi) - req) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + ) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -207,30 +207,30 @@ (change-slot-values poi 'airals (list (import-image uploaded-file :class-name 'store-image)))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-airal)) (poi poi) - req) + ) (let ((airals (poi-airals poi))) (change-slot-values poi 'airals nil) (mapc #'delete-object airals)) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-movie)) (poi poi) - req) + ) (change-slot-values poi 'movies nil) - (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req)) + (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-panorama)) (poi poi) - req) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + ) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -240,21 +240,21 @@ :class-name 'store-image) (poi-panoramas poi)))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-panorama)) (poi poi) - req) - (with-query-params (req panorama-id) + ) + (with-query-params (panorama-id) (let ((panorama (find-store-object (parse-integer panorama-id)))) (change-slot-values poi 'panoramas (remove panorama (poi-panoramas poi))) (mapc #'delete-object panorama))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :delete)) (poi poi) req) + (action (eql :delete)) (poi poi)) (delete-object poi) (with-bos-cms-page (req :title "POI has been deleted") (html (:h2 "POI has been deleted") @@ -266,8 +266,8 @@ () (:default-initargs :object-class 'poi-image)) -(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil)) req) - (with-query-params (req poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil))) + (with-query-params (poi) (with-bos-cms-page (req :title "Upload new POI image") (html (:h2 "Upload new image") @@ -276,10 +276,10 @@ (:p "Choose a file: " ((:input :type "file" :name "image-file"))) (:p (submit-button "upload" "upload")))))) -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image req) - (with-query-params (req poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image) + (with-query-params (poi) (setq poi (find-store-object (parse-integer poi) :class 'poi)) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -302,15 +302,15 @@ :initargs `(:poi ,poi)))) (redirect (format nil "/edit-poi-image/~D?poi=~D" (store-object-id poi-image) - (store-object-id poi)) req)))) + (store-object-id poi)))))) -(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image req) - (with-query-params (req language poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) + (with-query-params (language poi) (unless language (setq language (session-variable :language))) (with-bos-cms-page (req :title "Edit POI Image") (html (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI") - (content-language-chooser req) + (content-language-chooser) ((:form :method "post" :enctype "multipart/form-data") ((:input :type "hidden" :name "poi" :value poi)) (:table (:tr (:td "thumbnail") @@ -334,8 +334,8 @@ :cols 40))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the image?"))))))))) -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image req) - (with-query-params (req title subtitle description language) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) + (with-query-params (title subtitle description language) (unless language (setq language (session-variable :language))) (update-poi-image poi-image language :title title @@ -345,7 +345,7 @@ (:h2 "The POI image information has been updated") "You may " (cmslink (edit-object-url poi-image) "continue editing the POI image")))) -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image req) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image) (let ((poi (poi-image-poi poi-image))) (delete-object poi-image) (with-bos-cms-page (req :title "POI image has been deleted") @@ -363,28 +363,26 @@ (sponsor-country (contract-sponsor contract)) (length (contract-m2s contract)))) -(defmethod handle ((handler poi-javascript-handler) req) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) - (let ((*standard-output* *html-stream*)) - (princ "<script language=\"JavaScript\">") (terpri) - (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri) - (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) - (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) - (princ "</script>") (terpri))))) +(defmethod handle ((handler poi-javascript-handler)) + (with-http-response (:content-type "text/html; charset=UTF-8") + (no-cache) + (with-http-body () + (let ((*standard-output* *html-stream*)) + (princ "<script language=\"JavaScript\">") (terpri) + (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri) + (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) + (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) + (princ "</script>") (terpri))))) (defclass poi-image-handler (object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) -(defmethod handle-object ((handler poi-image-handler) (poi (eql nil)) req) +(defmethod handle-object ((handler poi-image-handler) (poi (eql nil))) (error "poi not found")) -(defmethod handle-object ((handler poi-image-handler) poi req) - (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler req)) +(defmethod handle-object ((handler poi-image-handler) poi) + (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler)) (declare (ignore poi-name)) (let ((image-index (1- (parse-integer image-index-string)))) (if (and (not (minusp image-index)) @@ -392,6 +390,6 @@ (redirect (format nil "/image/~D~@[~{/~a~}~]" (store-object-id (nth image-index (poi-images poi))) imageproc-arguments) - req) + ) (error "image index ~a out of bounds for poi ~a" image-index poi))))) Modified: branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/reports-xml-handler.lisp Tue Jan 29 07:19:19 2008 @@ -19,9 +19,9 @@ (declare (ignore second minute hour date month day-of-week is-dst tz)) year)) -(defmethod handle ((handler reports-xml-handler) req) +(defmethod handle ((handler reports-xml-handler)) (with-xml-response req - (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler req) + (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler) (setf *year* (and *year* (parse-integer *year*))) (let ((*contracts-to-process* (sort (remove-if (lambda (contract) (or (not (contract-paidp contract)) Modified: branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,23 +6,23 @@ (defclass search-sponsors-handler (admin-only-handler form-handler) ()) -(defmethod handle-form ((handler search-sponsors-handler) action req) +(defmethod handle-form ((handler search-sponsors-handler) action) (with-bos-cms-page (req :title "Search for sponsor"))) (defclass edit-sponsor-handler (admin-only-handler edit-object-handler) ()) -(defmethod object-handler-get-object ((handler edit-sponsor-handler) req) - (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler req))))))) +(defmethod object-handler-get-object ((handler edit-sponsor-handler)) + (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler))))))) (typecase object (sponsor object) (contract (contract-sponsor object)) (otherwise nil)))) -(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil)) req) - (with-query-params (req id key count) +(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil))) + (with-query-params (id key count) (when id - (redirect #?"/edit-sponsor/$(id)" req) + (redirect #?"/edit-sponsor/$(id)") (return-from handle-object-form)) (when (or key count) (let ((regex (format nil "(?i)~A" key)) @@ -90,22 +90,22 @@ (defun date-to-universal (date-string) (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"\." date-string)))) -(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req) - (with-query-params (req numsqm country email name address date language) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil))) + (with-query-params (numsqm country email name address date language) (let* ((sponsor (make-sponsor :email email :country country)) (contract (make-contract sponsor (parse-integer numsqm) :paidp (format nil "~A: manually created by ~A" (format-date-time (get-universal-time)) - (user-login (bknr-request-user req))) + (user-login (bknr-request-user))) :date (date-to-universal date)))) (contract-issue-cert contract name :address address :language language) - (mail-backoffice-sponsor-data contract req) - (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req)))) + (mail-backoffice-sponsor-data contract) + (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)))))) (defun contract-checkbox-name (contract) (format nil "contract-~D-paid" (store-object-id contract))) -(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor) (with-bos-cms-page (req :title "Edit Sponsor") (html ((:form :method "post") @@ -154,28 +154,28 @@ (:p (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete this sponsor?")))))) -(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor) (let (changed) (with-bos-cms-page (req :title "Saving sponsor data") (dolist (field-name '(full-name email password country info-text)) - (let ((field-value (query-param req (string-downcase (symbol-name field-name))))) + (let ((field-value (query-param (string-downcase (symbol-name field-name))))) (when (and field-value (not (equal field-value (slot-value sponsor field-name)))) (change-slot-values sponsor field-name field-value) (setf changed t) (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name)))))))) (dolist (contract (sponsor-contracts sponsor)) - (when (and (query-param req (contract-checkbox-name contract)) + (when (and (query-param (contract-checkbox-name contract)) (not (contract-paidp contract))) (change-slot-values contract 'paidp t) (setf changed t) (html (:p "Changed contract status to \"paid\"")))) (unless changed (html (:p "No changes have been made"))) - (html (cmslink (uri-path (request-uri req)) + (html (cmslink (uri-path (request-uri)) "Return to sponsor profile"))))) -(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor) (with-bos-cms-page (req :title "Sponsor deleted") (delete-object sponsor) (html (:p "The sponsor has been deleted")))) @@ -184,16 +184,16 @@ () (:default-initargs :object-class 'contract)) -(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil)) req) +(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil))) (with-bos-cms-page (req :title "Invalid contract ID") (html "Invalid contract ID, maybe the sponsor or the contract has been deleted"))) -(defmethod handle-object-form ((handler complete-transfer-handler) action contract req) +(defmethod handle-object-form ((handler complete-transfer-handler) action contract) (if (contract-paidp contract) (redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract))) req) (let ((numsqm (length (contract-m2s contract)))) - (with-query-params (req email) + (with-query-params (email) (with-bos-cms-page (req :title "Complete square meter sale with wire transfer payment") (html ((:form :name "form") @@ -214,8 +214,8 @@ (:td (text-field "email" :size 20 :value email))) (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()"))))))))))) -(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract req) - (with-query-params (req email country language) +(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract) + (with-query-params (email country language) (with-bos-cms-page (req :title "Square meter sale completion") (if (contract-paidp contract) (html (:h2 "This sale has already been completed")) @@ -223,7 +223,7 @@ (html (:h2 "Completing square meter sale")) (sponsor-set-country (contract-sponsor contract) country) (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A" - (format-date-time) (user-login (bknr-request-user req)))) + (format-date-time) (user-login (bknr-request-user)))) (when email (html (:p "Sending instruction email to " (:princ-safe email))) (mail-instructions-to-sponsor contract email)))) @@ -233,8 +233,8 @@ (defclass m2-javascript-handler (prefix-handler) ()) -(defmethod handle ((handler m2-javascript-handler) req) - (multiple-value-bind (sponsor-id-or-x y) (parse-url req) +(defmethod handle ((handler m2-javascript-handler)) + (multiple-value-bind (sponsor-id-or-x y) (parse-url) (let ((sponsor (cond (y (let ((m2 (get-m2 (parse-integer sponsor-id-or-x) (parse-integer y)))) @@ -243,10 +243,10 @@ (sponsor-id-or-x (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor)) (t - (when (eq (find-class 'sponsor) (class-of (bknr-request-user req))) - (bknr-request-user req)))))) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (with-http-body (req *ent*) + (when (eq (find-class 'sponsor) (class-of (bknr-request-user))) + (bknr-request-user)))))) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () (let ((*standard-output* *html-stream*)) (princ "<script language=\"JavaScript\">") (terpri) (princ "var profil;") (terpri) @@ -258,16 +258,14 @@ (defclass sponsor-login-handler (page-handler) ()) -(defmethod handle ((handler sponsor-login-handler) req) - (with-query-params (req __sponsorid) - (with-bknr-http-response (req :content-type "text/html") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) +(defmethod handle ((handler sponsor-login-handler)) + (with-query-params (__sponsorid) + (with-http-response (:content-type "text/html") + (no-cache) + (with-http-body () (format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%" (cond - ((eq (find-class 'sponsor) (class-of (bknr-request-user req))) + ((eq (find-class 'sponsor) (class-of (bknr-request-user))) "logged-in") (__sponsorid "login-failed") @@ -278,8 +276,8 @@ () (:default-initargs :class 'contract)) -(defmethod object-handler-get-object ((handler cert-regen-handler) req) - (let* ((object-id-string (first (decoded-handler-path handler req))) +(defmethod object-handler-get-object ((handler cert-regen-handler)) + (let* ((object-id-string (first (decoded-handler-path handler))) (object (store-object-with-id (parse-integer object-id-string)))) (cond ((contract-p object) @@ -288,7 +286,7 @@ (first (sponsor-contracts object))) (t (error "invalid sponsor or contract id ~A" object-id-string))))) -(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract) req) +(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract)) (with-bos-cms-page (req :title "Re-generate Certificate") (html ((:form :name "form") @@ -307,12 +305,12 @@ (html (:tr (:td (submit-button "regenerate" "regenerate"))))))))) -(defun confirm-cert-regen (req) +(defun confirm-cert-regen () (with-bos-cms-page (req :title "Certificate generation request has been created") (html "Your certificate generation request has been created, please wait a few seconds before checking the PDF file"))) -(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract) req) - (with-query-params (req name address language) +(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract)) + (with-query-params (name address language) (bos.m2::make-certificate contract name :address address :language language)) - (confirm-cert-regen req)) \ No newline at end of file + (confirm-cert-regen)) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp Tue Jan 29 07:19:19 2008 @@ -27,9 +27,8 @@ ((:p :class "footer") "local time is " (:princ-safe (format-date-time)) " - " - (if (and (equal 'bknr-request (type-of *req*)) - (bknr-request-user *req*)) - (html "logged in as " (html-link (bknr-request-user *req*))) + (if (bknr-request-user) + (html "logged in as " (html-link (bknr-request-user))) (html "not logged in")) " - current content language is " (cmslink "change-language" @@ -46,21 +45,21 @@ (setf (session-variable :language) *default-language*)) (session-variable :language)) -(defun content-language-chooser (req) +(defun content-language-chooser () (html ((:p :class "languages") "Content languages: " (loop for (language-symbol language-name) in (website-languages) do (labels ((show-language-link () - (html (cmslink (format nil "~A?language=~A" (uri-path (request-uri req)) language-symbol) + (html (cmslink (format nil "~A?language=~A" (uri-path (request-uri)) language-symbol) (:princ-safe language-name))))) (if (equal (session-variable :language) language-symbol) (html "[" (show-language-link) "]") (html (show-language-link))) (html " ")))))) -(defun decode-ismap-query-string (req) - (let ((coord-string (caar (request-query req)))) +(defun decode-ismap-query-string () + (let ((coord-string (caar (request-query)))) (when (and coord-string (scan #?r"^\d*,\d*$" coord-string)) (mapcar #'parse-integer (split "," coord-string))))) Modified: branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp (original) +++ branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp Tue Jan 29 07:19:19 2008 @@ -44,7 +44,7 @@ (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info"))))))) (call-next-method handler template-name)) -(defmethod initial-template-environment ((expander worldpay-template-handler) req) +(defmethod initial-template-environment ((expander worldpay-template-handler)) (append (list (cons :website-url *website-url*)) (call-next-method))) @@ -65,11 +65,11 @@ (when (website-supports-language language) language))) -(defun find-browser-prefered-language (req) +(defun find-browser-prefered-language () "Determine the language prefered by the user, as determined by the Accept-Language header present in the HTTP request. Header decoding is done according to RFC2616, considering individual language preference weights." - (let ((accept-language (header-slot-value req :accept-language))) + (let ((accept-language (header-slot-value :accept-language))) (dolist (language (mapcar #'car (sort (mapcar #'(lambda (language-spec-string) (if (find #\; language-spec-string) @@ -90,39 +90,39 @@ (defclass index-handler (page-handler) ()) -(defmethod handle ((handler index-handler) req) - (redirect (format nil "/~A/index" (or (find-browser-prefered-language req) +(defmethod handle ((handler index-handler)) + (redirect (format nil "/~A/index" (or (find-browser-prefered-language) *default-language*)) - req)) + )) (defclass infosystem-handler (page-handler) ()) -(defmethod handle ((handler infosystem-handler) req) +(defmethod handle ((handler infosystem-handler)) ;; XXX hier logout-parameter implementieren - (with-query-params (req logout) + (with-query-params (logout) (when logout - (bknr.web::drop-session (bknr-request-session req)))) + (bknr.web::drop-session (bknr-request-session)))) (let ((language (session-variable :language))) - (redirect #?"/infosystem/$(language)/satellitenkarte.htm" req))) + (redirect #?"/infosystem/$(language)/satellitenkarte.htm"))) (defclass certificate-handler (object-handler) () (:default-initargs :class 'contract)) -(defmethod handle-object ((handler certificate-handler) contract req) +(defmethod handle-object ((handler certificate-handler) contract) (unless contract - (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user req))))) - (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)) req)) + (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user))))) + (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)))) (defclass statistics-handler (admin-only-handler prefix-handler) ()) -(defmethod handle ((handler statistics-handler) req) - (let ((stats-name (parse-url req))) +(defmethod handle ((handler statistics-handler)) + (let ((stats-name (parse-url))) (cond (stats-name - (redirect (format nil "~A.svg" stats-name) req)) + (redirect (format nil "~A.svg" stats-name))) (t (with-bos-cms-page (req :title "Statistics browser") (:p @@ -136,15 +136,15 @@ (defclass admin-handler (admin-only-handler page-handler) ()) -(defmethod handle ((handler admin-handler) req) +(defmethod handle ((handler admin-handler)) (with-bos-cms-page (req :title "BOS CMS and Administration") "Please choose an administration activity from the menu above")) (defclass bos-authorizer (bknr-authorizer) ()) -(defmethod find-user-from-request-parameters ((authorizer bos-authorizer) req) - (with-query-params (req __sponsorid __password) +(defmethod find-user-from-request-parameters ((authorizer bos-authorizer)) + (with-query-params (__sponsorid __password) (if (and __sponsorid __password) (handler-case (let ((sponsor (find-store-object (parse-integer __sponsorid) :class 'sponsor))) @@ -159,18 +159,16 @@ (call-next-method))) (call-next-method)))) -(defmethod authorize :after ((authorizer bos-authorizer) - (req http-request) - (ent net.aserve::entity)) - (let ((new-language (or (language-from-url (uri-path (request-uri req))) - (query-param req "language"))) - (current-language (gethash :language (bknr-session-variables (bknr-request-session req))))) +(defmethod authorize :after ((authorizer bos-authorizer)) + (let ((new-language (or (language-from-url (uri-path (request-uri))) + (query-param "language"))) + (current-language (gethash :language (bknr-session-variables (bknr-request-session))))) (when (or (not current-language) (and new-language (not (equal new-language current-language)))) - (setf (gethash :language (bknr-session-variables (bknr-request-session req))) + (setf (gethash :language (bknr-session-variables (bknr-request-session))) (or new-language - (find-browser-prefered-language req) + (find-browser-prefered-language) *default-language*))))) (defun publish-worldpay-test (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild)) Modified: branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/breadcrumb.lisp Tue Jan 29 07:19:19 2008 @@ -14,14 +14,14 @@ (defclass breadcrumb-handler (prefix-handler) ()) -(defmethod handle ((handler breadcrumb-handler) req) - (let* ((id (parse-integer (parse-url req) :junk-allowed t)) +(defmethod handle ((handler breadcrumb-handler)) + (let* ((id (parse-integer (parse-url) :junk-allowed t)) (breadcrumb (when id (find id (session-variable :breadcrumbs) :key #'breadcrumb-id)))) (if breadcrumb (progn (setf (session-variable :current-breadcrumb) breadcrumb) - (redirect (breadcrumb-url breadcrumb) req)) - (redirect "/" req)))) + (redirect (breadcrumb-url breadcrumb))) + (redirect "/")))) (defun new-breadcrumb-id () (if (session-variable :breadcrumb-id) @@ -31,11 +31,11 @@ (defun add-breadcrumb (req title) (let ((current-crumb (session-variable :current-breadcrumb))) (unless (and current-crumb - (string-equal (uri-path (request-uri req)) + (string-equal (uri-path (request-uri)) (uri-path (breadcrumb-url current-crumb)))) (let ((breadcrumb (make-instance 'breadcrumb :id (new-breadcrumb-id) - :url (redirect-uri (request-uri req)) + :url (redirect-uri (request-uri)) :title title))) (setf (session-variable :breadcrumbs) (cons breadcrumb (member current-crumb (session-variable :breadcrumbs)))) @@ -45,4 +45,4 @@ (define-bknr-tag breadcrumb () (html ((:div :class "breadcrumb") - (:princ (caar (form-urlencoded-to-query (uri-path (request-uri *req*)))))))) \ No newline at end of file + (:princ (caar (form-urlencoded-to-query (uri-path (request-uri)))))))) \ No newline at end of file Modified: branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/dynasite-tags.lisp Tue Jan 29 07:19:19 2008 @@ -5,7 +5,7 @@ (define-bknr-tag dynasite-blog (&key name) "Display a dynasite blog" (let ((blog (find-store-object name :class 'blog :query-function #'blog-with-name)) - (page (query-param *req* "page"))) + (page (query-param "page"))) (when page (setf page (parse-integer page :junk-allowed t))) (unless page @@ -26,7 +26,7 @@ (html "Please enter a feedback message." :br (text-field "feedback" :size 85) (submit-button "feedback" "post"))))))) - (with-query-params (*req* feedback action) + (with-query-params (feedback action) (if (equal action "feedback") (if feedback (let ((mailinglist (mailinglist-with-name ml))) @@ -34,7 +34,7 @@ (progn (mailinglist-send-mail mailinglist - (let ((host (http-session-host *session*))) + (let ((host (bknr-session-host *session*))) (make-object 'mail :subject (format nil "feedback from ~A (~A)" (bknr.user:user-login *user*) Modified: branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/eboy-templates.lisp Tue Jan 29 07:19:19 2008 @@ -14,7 +14,7 @@ (defclass eboy-template-handler (template-handler) nil) -(defmethod initial-template-environment ((handler eboy-template-handler) req) +(defmethod initial-template-environment ((handler eboy-template-handler)) (unless (session-variable :chosen-color-theme) (setf (session-variable :chosen-color-theme) (random-elt *color-themes*))) @@ -22,6 +22,6 @@ (first (session-variable :chosen-color-theme))) (call-next-method))) -(defmethod handle :before ((handler eboy-template-handler) req) - (add-breadcrumb req (uri-path (request-uri req)))) +(defmethod handle :before ((handler eboy-template-handler)) + (add-breadcrumb (uri-path (request-uri)))) Modified: branches/trunk-reorg/projects/eboy/src/item-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/item-handlers.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/item-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -76,18 +76,18 @@ (when item (submit-button "delete" "delete" :confirm "Really delete item?"))))))) -(defmethod authorized-p ((handler edit-item-handler) req) - (admin-p (bknr-request-user req))) +(defmethod authorized-p ((handler edit-item-handler)) + (admin-p (bknr-request-user))) (defmethod handle-object-form ((handler edit-item-handler) - action item req) - (with-bknr-page (req :title (if item #?"edit item $((article-subject item))" "edit new item")) + action item) + (with-bknr-page (:title (if item #?"edit item $((article-subject item))" "edit new item")) (item-form :id (and item (store-object-id item))))) (defmethod handle-object-form ((handler edit-item-handler) - (action (eql :save)) item req) - (with-query-params (req name subject text item-keyword) - (let ((keywords (keywords-from-query-param-list (query-param-list req "keyword")))) + (action (eql :save)) item) + (with-query-params (name subject text item-keyword) + (let ((keywords (keywords-from-query-param-list (query-param-list "keyword")))) (setf item-keyword (when item-keyword (list (make-keyword-from-string item-keyword)))) (if item (progn @@ -102,10 +102,10 @@ :text text :image-keywords keywords :keywords item-keyword))))) - (redirect (edit-object-url item) req)) + (redirect (edit-object-url item))) (defmethod handle-object-form ((handler edit-item-handler) - (action (eql :delete)) item req) + (action (eql :delete)) item) (delete-object item) - (with-bknr-page (req :title "item has been deleted") + (with-bknr-page (:title "item has been deleted") (html "item has been deleted"))) \ No newline at end of file Modified: branches/trunk-reorg/projects/eboy/src/jerks.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/jerks.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/jerks.lisp Tue Jan 29 07:19:19 2008 @@ -3,8 +3,8 @@ (defclass autojerk-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler autojerk-handler) req) - (let* ((jerks (parse-handler-url handler req)) +(defmethod object-handler-get-object ((handler autojerk-handler)) + (let* ((jerks (parse-handler-url handler)) (jerk-ids (when jerks (split "," jerks))) (jerk-images (mapcar #'(lambda (id) @@ -19,13 +19,13 @@ jerk-images)) jerk-images))) -(defmethod handle-object ((handler autojerk-handler) (images (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((handler autojerk-handler) (images (eql nil))) + (error-404)) (defmethod handle-object ((handler autojerk-handler) - images req) + images) (format t ";; in handle-object for autojerk-handler~%") - (let ((operations (cdr (decoded-handler-path handler req)))) + (let ((operations (cdr (decoded-handler-path handler)))) (with-image (jerk-image (store-image-width (first images)) (store-image-height (first images)) t) @@ -61,13 +61,13 @@ proc)) (define-bknr-tag autojerk-thumbnail-page (&key (detail "/autojerk-detail")) - (unless (and (not (member "remix" (request-query *req*) + (unless (and (not (member "remix" (request-query) :test #'string-equal :key #'car)) (session-variable :current-autojerk-page)) (setf (session-variable :current-autojerk-page) (generate-autojerk-page))) (setf (session-variable :autojerk-page-uri) - (uri-path (request-uri *req*))) + (uri-path (request-uri))) (html ((:div :class "results") (let ((i 0)) (dolist (row (group-by (session-variable :current-autojerk-page) 8)) @@ -83,7 +83,7 @@ (unless (session-variable :current-autojerk-page) (setf (session-variable :current-autojerk-page) (generate-autojerk-page))) - (with-query-params (*req* image) + (with-query-params (image) (setf image (or (parse-integer image :junk-allowed t) 0)) (let* ((page (session-variable :current-autojerk-page)) (autojerk (nth image page))) @@ -94,19 +94,19 @@ ((:div :class "resultsnav") (if (equal autojerk (car page)) (html "<<< | previous") - (html ((:a :href (format nil "~a?image=0" (uri-path (request-uri *req*)))) + (html ((:a :href (format nil "~a?image=0" (uri-path (request-uri)))) "<<<") " | " - ((:a :href (format nil "~a?image=~a" (uri-path (request-uri *req*)) + ((:a :href (format nil "~a?image=~a" (uri-path (request-uri)) (1- image))) "previous"))) " | " (if (cdr (member autojerk page :test #'equal)) - (html ((:a :href (format nil "~a?image=~a" (uri-path (request-uri *req*)) + (html ((:a :href (format nil "~a?image=~a" (uri-path (request-uri)) (1+ image))) "next") " | " - ((:a :href (format nil "~a?image=~a" (uri-path (request-uri *req*)) + ((:a :href (format nil "~a?image=~a" (uri-path (request-uri)) (1- (length page)))) ">>>")) (html "next | >>>"))) Modified: branches/trunk-reorg/projects/eboy/src/layout.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/layout.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/layout.lisp Tue Jan 29 07:19:19 2008 @@ -546,11 +546,11 @@ ;; xxx ugly: make sure that at least (length new-path-components) path elements are processed (append (request-variable :template-args) (make-list (- (length new-path-components) (length (request-variable :template-args))))))) - (uri-path (request-uri *req*)))) + (uri-path (request-uri))) (defun make-page-url (&optional page-number) "Make a url pointing to the given page number of the same url as the current request" - (format nil "~a~@[/~a~]" (regex-replace #?r"/\d*$" (uri-path (request-uri *req*)) "") page-number)) + (format nil "~a~@[/~a~]" (regex-replace #?r"/\d*$" (uri-path (request-uri)) "") page-number)) (define-bknr-tag details-resultsbar (&key image) (let ((current-query-result (session-variable :current-query-result)) Modified: branches/trunk-reorg/projects/eboy/src/navi.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/navi.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/navi.lisp Tue Jan 29 07:19:19 2008 @@ -31,7 +31,7 @@ Argumente: active-color - Vordergrundfarbe (Schwarz wird ersetzt)" (destructuring-bind (empty first-level &rest rest) - (split "/" (uri-path (request-uri *req*))) + (split "/" (uri-path (request-uri))) (declare (ignore empty rest)) (dolist (button '(:eboy :browse :shop :about)) (if (string-equal (symbol-name button) first-level) @@ -42,7 +42,7 @@ "Erzeugt das Second-Level-Men�" (destructuring-bind (empty first-level &rest rest) - (split "/" (uri-path (request-uri *req*))) + (split "/" (uri-path (request-uri))) (declare (ignore empty rest)) (dolist (choice (website-menu *current-website*)) (when (and (string-equal (choice-link choice) first-level) Modified: branches/trunk-reorg/projects/eboy/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/packages.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/packages.lisp Tue Jan 29 07:19:19 2008 @@ -7,8 +7,8 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve - :net.html.generator + :hunchentoot + :xhtml-generator :bknr.datastore :bknr.utils :bknr.rss @@ -33,8 +33,8 @@ :eboy :cl-interpol :cl-ppcre - :net.html.generator - :net.aserve + :xhtml-generator + :hunchentoot :puri :bknr.web :bknr.datastore Modified: branches/trunk-reorg/projects/eboy/src/peecol.lisp ============================================================================== --- branches/trunk-reorg/projects/eboy/src/peecol.lisp (original) +++ branches/trunk-reorg/projects/eboy/src/peecol.lisp Tue Jan 29 07:19:19 2008 @@ -187,14 +187,14 @@ (define-bknr-tag peecol-page (&key (detail "/peecol-detail")) (if (or (not (session-variable :current-peecol-result)) - (member "remix" (request-query *req*) :test #'string-equal :key #'car)) + (member "remix" (request-query) :test #'string-equal :key #'car)) (setf (session-variable :current-peecol-result) (search-peecol-page))) - (setf (session-variable :query-result-page-uri) (uri-path (request-uri *req*))) + (setf (session-variable :query-result-page-uri) (uri-path (request-uri))) (let* ((results (session-variable :current-peecol-result)) (num-pages (length results)) - (page-num (parse-integer (or (query-param *req* "page") + (page-num (parse-integer (or (query-param "page") "0"))) (page (nth page-num results)) (peecolnr (* 6 (apply #'+ (mapcar #'length (subseq results 0 page-num))))) @@ -209,7 +209,7 @@ (if (zerop page-num) (html "previous ") (html ((:a :href - (format nil "~a?page=~a" (uri-path (request-uri *req*)) + (format nil "~a?page=~a" (uri-path (request-uri)) (1- page-num))) "previous "))) (loop for i from (max 0 (min (- page-num 2) (- num-pages 5))) @@ -219,13 +219,13 @@ (html (:princ-safe (1+ i))) (html ((:a :href (format nil "~a?page=~a" - (uri-path (request-uri *req*)) i)) + (uri-path (request-uri)) i)) (:princ-safe (1+ i))))))) (html " | ") (if (= page-num (1- num-pages)) (html "next ") (html ((:a :href (format nil "~a?page=~a" - (uri-path (request-uri *req*)) + (uri-path (request-uri)) (1+ page-num))) "next "))))))))) (html (resultsbar) @@ -256,7 +256,7 @@ (unless (session-variable :current-peecol-result) (setf (session-variable :current-peecol-result) (search-peecol-page))) - (with-query-params (*req* peecolnr) + (with-query-params (peecolnr) (setf peecolnr (if peecolnr (if (parse-integer peecolnr :junk-allowed t) (parse-integer peecolnr :junk-allowed t) @@ -274,14 +274,14 @@ (if (equal peecol-triple (first peecols)) (html "previous") (html ((:a :href (format nil "~a?peecolnr=~a" - (uri-path (request-uri *req*)) + (uri-path (request-uri)) (1- peecolnr))) "previous"))) " | " (if (eq peecolnr (1- peecols-count)) (html "next") (html ((:a :href (format nil "~a?peecolnr=~a" - (uri-path (request-uri *req*)) + (uri-path (request-uri)) (1+ peecolnr))) "next")))) ((:div :class "resultsinfo") Modified: branches/trunk-reorg/projects/gpn/add-user-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/add-user-handler.lisp (original) +++ branches/trunk-reorg/projects/gpn/add-user-handler.lisp Tue Jan 29 07:19:19 2008 @@ -21,22 +21,22 @@ (submit-button "create" "create"))))))) -(defmethod handle-form ((handler add-gpn-user-handler) (action (eql nil)) req) - (with-bknr-page (req :Title "Add gpn user") +(defmethod handle-form ((handler add-gpn-user-handler) (action (eql nil))) + (with-bknr-page (:Title "Add gpn user") (add-gpn-user-form))) (defmethod handle-form ((handler add-gpn-user-handler) (action (eql :create)) req) - (with-query-params (req login full-name email password password2 vortragender) + (with-query-params (login full-name email password password2 vortragender) (unless login - (with-bknr-page (req :title "add gpn user") + (with-bknr-page (:title "add gpn user") (:h2 "Error") "please give a login" (add-gpn-user-form :login login :full-name full-name :email email)) (return-from handle-form)) (unless (or (not password) (string-equal password password2)) - (with-bknr-page (req :title "add gpn user") + (with-bknr-page (:title "add gpn user") (:h2 "Error") "passwords did not match" (add-gpn-user-form :login login :full-name full-name :email email)) @@ -44,7 +44,7 @@ (let ((user (make-gpn-user login :full-name full-name :email email :flags (when vortragender (list :vortragender)) :password password))) - (with-bknr-page (req :title "added gpn user") + (with-bknr-page (:title "added gpn user") (:h2 "User " (:princ-safe (user-login user)) " added") ((:a :href (format nil "/gpn-user/~a" (user-login user))) (:princ-safe (user-login user))) Modified: branches/trunk-reorg/projects/gpn/gpn-tags.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/gpn-tags.lisp (original) +++ branches/trunk-reorg/projects/gpn/gpn-tags.lisp Tue Jan 29 07:19:19 2008 @@ -15,7 +15,7 @@ text) ; xxx for now (define-bknr-tag gpn-menu (&key (title "GULASCH PROGRAMMIER NACHT 3")) - (let ((first-level (second (split "/" (puri:uri-path (request-uri *req*)))))) + (let ((first-level (second (split "/" (puri:uri-path (request-uri)))))) (html ((:table :width 700 :cellpadding 0 :cellspacing 5) (:colgroup (dolist (b *gpn-buttons*) (html ((:col :width (third b))))) @@ -32,14 +32,14 @@ ((:a :class "headlink" :href (second button)) (:princ-safe (first button)))))) (html (:td)))) - (if (eql (find-user "anonymous") (bknr-request-user *req*)) + (if (eql (find-user "anonymous") (bknr-request-user)) (html ((:td :class "headbar") ((:a :class "headlogin" :href "/login") "LOGIN"))) (html ((:td :class "headbar") ((:a :class "headlogin" :href (format nil "/gpn-user/~a" - (user-login (bknr-request-user *req*)))) + (user-login (bknr-request-user)))) "HOME")) - (when (admin-p (bknr-request-user *req*)) + (when (admin-p (bknr-request-user)) (html ((:td :class "headbar") ((:a :class "headlogin" :href "/admin") "ADMIN")))) ((:td :class "headbar") @@ -71,7 +71,7 @@ (html "ANONYMOUS")) ", " (:princ-safe (format-date-time (article-time item) :show-weekday t)) - (when (equal (article-author item) (bknr-request-user *req*)) + (when (equal (article-author item) (bknr-request-user)) (html ((:a :href (format nil "/edit-article/~A" (store-object-id item))) " (edit)"))) )))) (html ((:a :class "rss" :href (format nil "~a/~a" (handler-url :blog-rss) @@ -86,7 +86,7 @@ (player (dj-player eboy::*dj*)) (status (when player (player-state player))) (mp3 (when status (ps-mp3 status))) - (action (query-param *req* "action"))) + (action (query-param "action"))) (when action (case (make-keyword-from-string action) (:feed (tamagotchi-feed tamagotchi :time (get-universal-time))) @@ -154,7 +154,7 @@ (when email (html ((:div :class "email") "EMAIL: " (:princ-safe (string-upcase (user-email user)))))))) - (when (string-equal (user-login user) (user-login (bknr-request-user *req*))) + (when (string-equal (user-login user) (user-login (bknr-request-user))) (html ((:div :class "user-edit") ((:p :class "news") "Zum Importieren von Bildern zuerst die Bilder auf ftp://fiep/ hochladen, @@ -278,11 +278,11 @@ (define-bknr-tag logged-in () (html ((:div :class "logged-in") "logged in as " - (if (string-equal (user-login (bknr-request-user *req*)) "anonymous") + (if (string-equal (user-login (bknr-request-user)) "anonymous") (html "anonymous") (html ((:a :style "color:#cc3333;" - :href (format nil "/gpn-user/~a" (user-login (bknr-request-user *req*)))) - (:princ-safe (user-login (bknr-request-user *req*))))))))) + :href (format nil "/gpn-user/~a" (user-login (bknr-request-user)))) + (:princ-safe (user-login (bknr-request-user))))))))) (define-bknr-tag gpn-fahrplan (&key location) (let ((events (sort (remove-if #'(lambda (event) (< (zeitplan-event-end-time event) (get-universal-time))) @@ -414,5 +414,5 @@ (html "ANONYMOUS")) ", " (:princ-safe (format-date-time (article-time article) :show-weekday t)) - (when (equal (article-author article) (bknr-request-user *req*)) + (when (equal (article-author article) (bknr-request-user)) (html ((:a :href (format nil "/edit-article/~A" (store-object-id article))) " (edit)")))))))))) Modified: branches/trunk-reorg/projects/gpn/import-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/import-handler.lisp (original) +++ branches/trunk-reorg/projects/gpn/import-handler.lisp Tue Jan 29 07:19:19 2008 @@ -5,8 +5,8 @@ (defclass gpn-import-handler (image-import-handler) ()) -(defmethod import-handler-import-pathname ((handler gpn-import-handler) req) - (let* ((user (bknr-request-user req)) +(defmethod import-handler-import-pathname ((handler gpn-import-handler)) + (let* ((user (bknr-request-user)) (spool-dir (merge-pathnames (make-pathname :directory (list :relative (user-login user) "images")) @@ -14,8 +14,8 @@ (ensure-directories-exist spool-dir) spool-dir)) -(defmethod handle-form ((handler image-import-handler) action req) - (with-bknr-page (req :title #?"image import directory") +(defmethod handle-form ((handler image-import-handler) action) + (with-bknr-page (:title #?"image import directory") ((:form :method "post") (when (admin-p *user*) (html ((:div :class "keyword-choose" :align "center") @@ -27,29 +27,29 @@ ((:div :class "import-list") (:h2 "Images present in import spool:") - (loop for file in (import-handler-spool-files handler req) + (loop for file in (import-handler-spool-files handler) do (html (:princ-safe (namestring file)) (:br)))))) -(defmethod import-handler-import-files ((handler image-import-handler) req) - (let* ((keywords (keywords-from-query-param-list (query-param-list req "keyword"))) - (spool-dir (import-handler-import-pathname handler req))) +(defmethod import-handler-import-files ((handler image-import-handler)) + (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword"))) + (spool-dir (import-handler-import-pathname handler))) (import-directory spool-dir - :user (bknr-request-user req) + :user (bknr-request-user) :keywords (when (admin-p *user*) keywords) :spool (import-handler-spool-dir handler) :keywords-from-dir (if (admin-p *user*) - (query-param req "keyfromdir") + (query-param "keyfromdir") t)))) -(defmethod handle-form ((handler image-import-handler) (action (eql :import)) req) - (let* ((import-log (import-handler-import-files handler req)) +(defmethod handle-form ((handler image-import-handler) (action (eql :import))) + (let* ((import-log (import-handler-import-files handler)) (successful-images (remove-if-not #'(lambda (element) (typep element 'store-image)) import-log :key #'cdr)) (error-log (remove-if-not #'(lambda (element) (typep element 'error)) import-log :key #'cdr))) - (with-bknr-page (req :title #?"gpn import log") + (with-bknr-page (:title #?"gpn import log") ((:div :class "error-log") (:h2 "Errors during import:") (loop for (file . error) in error-log do (typecase error Modified: branches/trunk-reorg/projects/gpn/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/packages.lisp (original) +++ branches/trunk-reorg/projects/gpn/packages.lisp Tue Jan 29 07:19:19 2008 @@ -7,7 +7,7 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :xhtml-generator :bknr.indices :bknr.datastore @@ -25,7 +25,7 @@ (:use :cl :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :xhtml-generator :bknr.utils :bknr.datastore Modified: branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp (original) +++ branches/trunk-reorg/projects/gpn/zeitplan-handlers.lisp Tue Jan 29 07:19:19 2008 @@ -4,7 +4,7 @@ ()) #+(or) -(defmethod create-rss-feed ((handler zeitplan-rss-handler) req) +(defmethod create-rss-feed ((handler zeitplan-rss-handler)) (let* ((events (sort (all-zeitplan-events) #'< :key #'zeitplan-event-start-time)) (url (website-url (page-handler-site handler))) (items (mapcar #'zeitplan-event-to-rss-item events))) @@ -21,13 +21,13 @@ () (:default-initargs :object-class 'zeitplan-event)) -(defmethod authorized-p ((handler edit-zeitplan-handler) req) +(defmethod authorized-p ((handler edit-zeitplan-handler)) (or (admin-p *user*) (user-has-flag *user* :vortragender))) (defmethod handle-object-form ((handler edit-zeitplan-handler) - action event req) - (with-bknr-page (req :title "edit zeitplan event") + action event) + (with-bknr-page (:title "edit zeitplan event") (if event (html (:h2 "Edit event " (:princ-safe (zeitplan-event-name event)) ":") (gpn-commands:zeitplan-event-form @@ -46,10 +46,10 @@ (html (:li (edit-html-link event))))) )))) (defmethod handle-object-form ((handler edit-zeitplan-handler) - (action (eql :create)) event req) - (with-query-params (req name description vortragender location) - (let ((start (parse-date-field "start" req)) - (end (parse-date-field "end" req)) + (action (eql :create)) event) + (with-query-params (name description vortragender location) + (let ((start (parse-date-field "start")) + (end (parse-date-field "end")) (vortragender (find-user (string-downcase vortragender)))) (handler-case (progn (ensure-form-field name) @@ -66,9 +66,9 @@ :location (make-keyword-from-string location) :start-time start :end-time end))) - (redirect (edit-object-url event) req))) + (redirect (edit-object-url event)))) (form-field-missing-condition (e) - (with-bknr-page (req :title "edit zeitplan event") + (with-bknr-page (:title "edit zeitplan event") ((:h2 :class "error") "Please fill field " (:princ-safe (form-field-missing-condition-field e)) "!") (gpn-commands:zeitplan-event-form :name name @@ -83,14 +83,14 @@ (defmethod handle-object-form ((handler edit-zeitplan-handler) - (action (eql :save)) event req) + (action (eql :save)) event) (unless event - (redirect (handler-url :edit-zeitplan) req) + (redirect (handler-url :edit-zeitplan)) (return-from handle-object-form)) - (with-query-params (req name description vortragender location) - (let ((start (parse-date-field "start" req)) - (end (parse-date-field "end" req)) + (with-query-params (name description vortragender location) + (let ((start (parse-date-field "start")) + (end (parse-date-field "end")) (vortragender (find-user (string-downcase vortragender)))) (when name (change-slot-values event 'name name)) @@ -104,10 +104,10 @@ (zeitplan-event-set-vortragender event vortragender)) (when location (zeitplan-event-set-location event (make-keyword-from-string location))) - (redirect (edit-object-url event) req)))) + (redirect (edit-object-url event))))) (defmethod handle-object-form ((handler edit-zeitplan-handler) - (action (eql :delete)) event req) + (action (eql :delete)) event) (when event (delete-object event)) - (redirect (handler-url :edit-zeitplan) req)) + (redirect (handler-url :edit-zeitplan))) Modified: branches/trunk-reorg/projects/hello-web/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/handlers.lisp Tue Jan 29 07:19:19 2008 @@ -6,13 +6,13 @@ () (:default-initargs :query-function #'find-user)) -(defmethod handle-object ((handler hello-object-handler) (object (eql nil)) req) - (with-bknr-page (req :title "object not found") - (html (:p "user " (:b (:princ-safe (first (decoded-handler-path handler req)))) " not found")))) +(defmethod handle-object ((handler hello-object-handler) (object (eql nil))) + (with-bknr-page (:title "object not found") + (html (:p "user " (:b (:princ-safe (first (decoded-handler-path handler)))) " not found")))) -(defmethod handle-object ((handler hello-object-handler) object req) - (with-bknr-page (req :title "demo handler") +(defmethod handle-object ((handler hello-object-handler) object) + (with-bknr-page (:title "demo handler") (html (:p "This is the demo handler, the object id of user " - (:b (:princ-safe (first (decoded-handler-path handler req)))) " is " + (:b (:princ-safe (first (decoded-handler-path handler)))) " is " (:b (:princ-safe (store-object-id object))))))) Modified: branches/trunk-reorg/projects/hello-web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/packages.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/packages.lisp Tue Jan 29 07:19:19 2008 @@ -17,7 +17,6 @@ :hello-web.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) (:export #:hello)) (defpackage :hello-web.imageproc @@ -43,8 +42,7 @@ :bknr.indices :bknr.rss :hello-web.config - :net.aserve + :hunchentoot :xhtml-generator) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) (:export)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp Tue Jan 29 07:19:19 2008 @@ -13,7 +13,7 @@ () (:default-initargs :class 'participant :query-function #'find-user)) -(defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant) req) +(defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant)) (with-lisp-ecoop-page (req #?"Edit participant $((user-login participant))") ((:form :method "post" :enctype "multipart/form-data") ((:table :border "1") @@ -27,7 +27,7 @@ (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Delete this participant?")))) -(defmethod handle-object-form ((handler edit-participant-handler) (action (eql :reset-password)) (participant participant) req) +(defmethod handle-object-form ((handler edit-participant-handler) (action (eql :reset-password)) (participant participant)) (participant-reset-password participant) (with-lisp-ecoop-page (req "Password reset") "The participant's password has been reset and sent by mail")) @@ -36,18 +36,18 @@ () (:default-initargs :class 'document)) -(defmethod handle-object ((handler pdf-handler) (document document) req) +(defmethod handle-object ((handler pdf-handler) (document document)) (let ((pdf (file-contents (blob-pathname document)))) - (with-http-response (req *ent* :content-type "application/pdf") - (setf (request-reply-content-length req) (length pdf)) - (with-http-body (req *ent* :external-format '(unsigned-byte 8)) - (write-sequence pdf net.aserve::*html-stream*))))) + (with-http-response (:content-type "application/pdf") + (setf (request-reply-content-length) (length pdf)) + (with-http-body (:external-format '(unsigned-byte 8)) + (write-sequence pdf *html-stream*))))) (defclass make-submission-handler (admin-only-handler page-handler) ()) -(defmethod handle ((handler make-submission-handler) req) - (with-query-params (req type title abstract) +(defmethod handle ((handler make-submission-handler)) + (with-query-params (type title abstract) (let ((submission (make-object (if (string-equal type "paper") 'paper 'breakout-group-proposal) :title title :abstract abstract))) (with-lisp-ecoop-page (req #?"Submission created") (html ((:script :type "text/javascript") @@ -63,32 +63,32 @@ () (:default-initargs :class 'submission)) -(defmethod handle-object ((handler upload-document-handler) object req) +(defmethod handle-object ((handler upload-document-handler) object) (error "Missing object ID")) -(defmethod handle-object ((handler upload-document-handler) (submission submission) req) +(defmethod handle-object ((handler upload-document-handler) (submission submission)) (unless (submission-edit-permitted-p submission) (error "can't edit this submission")) - (ecase (request-method req) + (ecase (request-method) (:post - (when (request-uploaded-file req "document") - (with-query-params (req info) + (when (request-uploaded-file "document") + (with-query-params (info) (format t "; new document - info ~S~%" info) - (let ((file-name (request-uploaded-file req "document"))) + (let ((file-name (request-uploaded-file "document"))) (with-open-file (pdf file-name) (if (cl-ppcre:scan "^%PDF-" (read-line pdf)) (let ((document (make-object 'document :info info :submission submission))) (blob-from-file document file-name) - (redirect (format-object-id "/upload/~A?success=1" submission) req)) - (redirect (format-object-id "/upload/~A?failure=~A" submission (uriencode-string "Uploaded file does not appear to be a PDF file")) req))))))) + (redirect (format-object-id "/upload/~A?success=1" submission))) + (redirect (format-object-id "/upload/~A?failure=~A" submission (uriencode-string "Uploaded file does not appear to be a PDF file"))))))))) (:get - (redirect (format-object-id "/upload/~A" submission) req)))) + (redirect (format-object-id "/upload/~A" submission))))) (defclass delete-document-handler (object-handler) () (:default-initargs :class 'document)) -(defmethod handle-object ((handler delete-document-handler) (document document) req) +(defmethod handle-object ((handler delete-document-handler) (document document)) (unless (submission-edit-permitted-p (document-submission document)) (error "can't edit this submission")) (delete-object document)) @@ -96,7 +96,7 @@ (defclass admin-handler (admin-only-handler page-handler) ()) -(defmethod handle ((handler page-handler) req) +(defmethod handle ((handler page-handler)) (with-lisp-ecoop-page (req "LISP-ECOOP Administration") "Please choose an administrative task from the menu")) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp Tue Jan 29 07:19:19 2008 @@ -38,8 +38,8 @@ "Generic submission") (defun submission-edit-permitted-p (submission) - (or (admin-p (bknr-request-user *req*)) - (find (bknr-request-user *req*) (submission-submitters submission)))) + (or (admin-p (bknr-request-user)) + (find (bknr-request-user) (submission-submitters submission)))) (defmethod submission-add-submitter ((submission submission) submitter) (pushnew submitter (submission-submitters submission)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp Tue Jan 29 07:19:19 2008 @@ -39,8 +39,8 @@ (or (ignore-errors (parse-integer string)) (ext:parse-time string :default-zone -2))) ; XXX deal with time zone correctly! -(defmethod handle ((handler schedule-handler) req) - (destructuring-bind (&optional begin end) (mapcar #'parse-time-spec (multiple-value-list (parse-url req))) +(defmethod handle ((handler schedule-handler)) + (destructuring-bind (&optional begin end) (mapcar #'parse-time-spec (multiple-value-list (parse-url))) (unless begin (setf begin (get-universal-time))) (unless end @@ -48,7 +48,7 @@ (labels ((timeslot-wanted (timeslot) (and (>= (timeslot-begin-time timeslot) begin) (<= (timeslot-begin-time timeslot) end)))) - (with-bknr-page (req :title "Schedule") + (with-bknr-page (:title "Schedule") (html (:table (:tr (:th "Time") (:th "Content")) (dolist (timeslot (sort (remove-if-not #'timeslot-wanted (class-instances 'timeslot)) @@ -60,8 +60,8 @@ () (:default-initargs :object-class 'timeslot)) -(defmethod handle-object-form ((handler edit-timeslot-handler) action timeslot req) - (with-bknr-page (req :title "Edit Timeslot") +(defmethod handle-object-form ((handler edit-timeslot-handler) action timeslot) + (with-bknr-page (:title "Edit Timeslot") ((:form :method "POST") ((:label :for "date") "Time:") ((:input :type "text" :size "5" :name "date" :value (format-date-time (timeslot-begin-time timeslot) :show-date nil :show-seconds nil))) @@ -74,8 +74,8 @@ :br (submit-button "delete" "delete")))) -(defmethod handle-object-form ((handler edit-timeslot-handler) (action (eql :delete)) timeslot req) - (with-bknr-page (req :title "Delete Timeslot") +(defmethod handle-object-form ((handler edit-timeslot-handler) (action (eql :delete)) timeslot) + (with-bknr-page (:title "Delete Timeslot") (delete-object timeslot) (html (:h2 "Timeslot has been deleted")))) @@ -93,7 +93,7 @@ #'< :key #'timeslot-begin-time)) (with-tag-expanders ((time () - (if (admin-p (bknr-request-user *req*)) + (if (admin-p (bknr-request-user)) (html ((:a :href #?"/edit-timeslot/$((store-object-id timeslot))") (:princ-safe (timeslot-time-string timeslot)))) (html (:princ-safe (timeslot-time-string timeslot))))) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp Tue Jan 29 07:19:19 2008 @@ -20,20 +20,20 @@ (if (parse-integer key :junk-allowed t) (find-store-object (parse-integer key :junk-allowed t)) (find-user key)) - (bknr-request-user *req*)))) + (bknr-request-user)))) (define-bknr-tag profile-editor (&key children) - (when (anonymous-p (bknr-request-user *req*)) + (when (anonymous-p (bknr-request-user)) (warn "User not logged in") (html (:h2 "Please log in to edit the profile")) (return-from profile-editor)) (let ((participant (participant-from-request))) - (unless (or (admin-p (bknr-request-user *req*)) - (eq participant (bknr-request-user *req*))) + (unless (or (admin-p (bknr-request-user)) + (eq participant (bknr-request-user))) (html (:h2 "can't edit this profile")) (return-from profile-editor)) - (when (eq :post (request-method *req*)) - (with-query-params (*req* action) + (when (eq :post (request-method)) + (with-query-params (action) (format t ";; ACTION ~A~%" action) (case (make-keyword-from-string action) (:delete-submission @@ -54,10 +54,10 @@ (delete-object participant) (html (:h2 "Participant has been deleted")) (return-from profile-editor)))) - (when (request-uploaded-file *req* "document") - (with-query-params (*req* type title abstract info) + (when (request-uploaded-file "document") + (with-query-params (type title abstract info) (format t "; new submission - title ~S abstract ~S~%" title abstract) - (let ((file-name (request-uploaded-file *req* "document"))) + (let ((file-name (request-uploaded-file "document"))) (with-open-file (pdf file-name) (if (cl-ppcre:scan "^%PDF-" (read-line pdf)) (let* ((submission (make-object (if (equal type "breakout-group-proposal") @@ -69,8 +69,8 @@ (with-transaction ("adding participant submission") (push submission (participant-submissions participant)))) (html ((:script :language "JavaScript") "alert('Invalid file format of uploaded, only PDF files are accepted')"))))))) - (when (request-uploaded-file *req* "picture") - (let ((picture (import-image (request-uploaded-file *req* "picture")))) + (when (request-uploaded-file "picture") + (let ((picture (import-image (request-uploaded-file "picture")))) (with-transaction ("updating participant picture") (when (participant-picture participant) (delete-object (participant-picture participant))) @@ -112,25 +112,25 @@ (unless (submission-edit-permitted-p submission) (html (:h2 "can't edit this submission")) (return-from submission-editor)) - (when (eq :post (request-method *req*)) - (with-query-params (*req* action) + (when (eq :post (request-method)) + (with-query-params (action) (case (make-keyword-from-string action) (:delete (delete-object submission) (html (:h2 "The submission has been deleted")) (return-from submission-editor)))) - (when (request-uploaded-file *req* "document") - (let ((file-name (request-uploaded-file *req* "document"))) + (when (request-uploaded-file "document") + (let ((file-name (request-uploaded-file "document"))) (with-open-file (pdf file-name) (cond ((cl-ppcre:scan "^%PDF-" (read-line pdf)) (html (:h2 "New document has been saved")) - (with-query-params (*req* info) + (with-query-params (info) (let ((document (make-object 'document :info info :submission submission))) (blob-from-file document file-name)))) (t (html ((:script :language "JavaScript") "alert('Invalid file format of uploaded, only PDF files are accepted')"))))))) - (with-query-params (*req* title abstract remove-submitter-id add-submitter-id) + (with-query-params (title abstract remove-submitter-id add-submitter-id) (html (:h2 "Submission updated")) (with-transaction ("updating submission") (when add-submitter-id @@ -146,12 +146,12 @@ (mapc #'emit-template-node children)))) (define-bknr-tag add-participant (&key children) - (unless (admin-p (bknr-request-user *req*)) + (unless (admin-p (bknr-request-user)) (html "You must be logged in as adminstrator to create new participants") (return-from add-participant)) - (with-query-params (*req* action) + (with-query-params (action) (when (eq :create (make-keyword-from-string action)) - (with-query-params (*req* login full-name email text submission) + (with-query-params (login full-name email text submission) (when (find-user login) (error "user ~A already exists" login)) (when submission @@ -175,7 +175,7 @@ (unless (submission-edit-permitted-p submission) (html (:h2 "can't edit this submission")) (return-from submission-submitter-editor)) - (with-query-params (*req* add-submitter-id remove-submitter-id add-submitter remove-submitter) + (with-query-params (add-submitter-id remove-submitter-id add-submitter remove-submitter) (let ((submitters (submission-submitters submission))) (cond (add-submitter-id @@ -192,13 +192,15 @@ (html (:strong "Add submitter") (:ul (dolist (participant (set-difference (class-instances 'participant) submitters)) - (html (:li ((:a :href (format nil "~A?add-submitter-id=~A" (puri:uri-path (request-uri *req*)) (store-object-id participant))) + (html (:li ((:a :href (format nil "~A?add-submitter-id=~A" + (puri:uri-path (request-uri)) + (store-object-id participant))) (:princ-safe (user-full-name participant))))))))) (remove-submitter (html (:strong "Remove Submitter") (:ul (dolist (participant submitters) - (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (puri:uri-path (request-uri *req*)) (store-object-id participant))) + (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (puri:uri-path (request-uri)) (store-object-id participant))) (:princ-safe (user-full-name participant)))))))))))))) (define-bknr-tag submission-uploader () @@ -250,18 +252,18 @@ (html ((:img :src (format-object-id "/image/~A/cell" image))))) (:span ((:a :href (format-object-id "/profile/~A" participant)) (:princ-safe (user-full-name participant))) - (when (or (eq participant (bknr-request-user *req*)) - (admin-p (bknr-request-user *req*))) + (when (or (eq participant (bknr-request-user)) + (admin-p (bknr-request-user))) (html " " ((:a :href (format-object-id "/edit-profile/~A" participant)) "[Edit]"))))))))) (define-bknr-tag participants-only (&key children error) - (if (participant-p (bknr-request-user *req*)) + (if (participant-p (bknr-request-user)) (mapc #'emit-template-node children) (when error (html (:princ-safe error))))) (define-bknr-tag admin-only (&key children error) - (if (admin-p (bknr-request-user *req*)) + (if (admin-p (bknr-request-user)) (mapc #'emit-template-node children) (when error (html (:princ-safe error))))) @@ -285,7 +287,7 @@ (html "[no submission]"))) (define-bknr-tag login-widget () - (let ((user (bknr-request-user *req*))) + (let ((user (bknr-request-user))) (cond ((anonymous-p user) (html ((:form :method "post") @@ -293,19 +295,19 @@ ((:input :type "text" :name "__username")) "Password" :br ((:input :type "password" :name "__password")) - (when (query-param *req* "__username") + (when (query-param "__username") (html ((:div :id "logfail") "Login failed"))) ((:button :type "submit" :name "action" :value "login") "login")))) (t (html ((:form :method "post" :action (website-make-path *website* "logout")) - ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri *req*)))) + ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri)))) (:div "Logged in as " :br ((:a :href (format-object-id "/edit-profile/~A" user)) (:princ-safe (user-full-name user)))) (:div ((:button :type "submit" :name "action" :value "logout") "logout")))))))) (define-bknr-tag admin-only (&key children) - (when (admin-p (bknr-request-user *req*)) + (when (admin-p (bknr-request-user)) (mapc #'emit-template-node children))) (defun parse-duration (string) @@ -314,8 +316,8 @@ (* 60 (+ (* 60 hours) minute))))) (define-bknr-tag schedule-submission () - (when (eq :post (request-method *req*)) - (with-query-params (*req* date time duration submission freetext) + (when (eq :post (request-method)) + (with-query-params (date time duration submission freetext) (let ((start (ext:parse-time (format nil "~A ~A" date time) :default-zone -2)) ; XXX hardcoded time zone (duration (parse-duration duration)) (submission (ignore-errors (store-object-with-id (parse-integer submission :junk-allowed t))))) Modified: branches/trunk-reorg/projects/mah-jongg/src/game.lisp ============================================================================== --- branches/trunk-reorg/projects/mah-jongg/src/game.lisp (original) +++ branches/trunk-reorg/projects/mah-jongg/src/game.lisp Tue Jan 29 07:19:19 2008 @@ -108,11 +108,11 @@ (text (princ-to-string (cadr (find player results :key #'car))))))))))) (defun request-param (req name) - (assoc name (request-query req) :test #'equal)) + (assoc name (request-query) :test #'equal)) -(defun handle-game (req ent) - (when (eq :post (request-method req)) - (with-query-params (req action undo-timestamp east north west south winner) +(defun handle-game () + (when (eq :post (request-method)) + (with-query-params (action undo-timestamp east north west south winner) (ecase (make-keyword-from-string action) (:undo (restore (parse-integer undo-timestamp))) @@ -122,12 +122,12 @@ (make-game (1- (get-universal-time)) (name (wind->player (make-keyword-from-string winner))) (mapcar #'(lambda (wind) (list (name (wind->player wind)) - (parse-integer (query-param req (symbol-name wind))))) + (parse-integer (query-param (symbol-name wind))))) '(:east :north :west :south)))) (:clear-round (clear-round))))) - (with-http-response (req ent :content-type "text/xml") - (with-http-body (req ent) + (with-http-response (:content-type "text/xml") + (with-http-body () (with-xml-output (cxml:make-character-stream-sink *html-stream*) (sax:processing-instruction cxml::*sink* (runes:string-rod "xml-stylesheet") (runes:string-rod "type=\"text/xsl\" href=\"game.xsl\"")) (if *round* Modified: branches/trunk-reorg/projects/mah-jongg/src/package.lisp ============================================================================== --- branches/trunk-reorg/projects/mah-jongg/src/package.lisp (original) +++ branches/trunk-reorg/projects/mah-jongg/src/package.lisp Tue Jan 29 07:19:19 2008 @@ -7,6 +7,6 @@ :bknr.utils :bknr.web :bknr.datastore - :net.aserve - :net.html.generator) + :hunchentoot + :xhtml-generator) (:export)) \ No newline at end of file Modified: branches/trunk-reorg/projects/quickhoney/src/config.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/config.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/config.lisp Tue Jan 29 07:19:19 2008 @@ -3,10 +3,10 @@ ;; URL für BASE HREFs (defparameter *website-url* "http://quickhoney.com") -(defparameter *root-directory* #p"home:bknr-svn/projects/quickhoney/") +(defparameter *root-directory* (merge-pathnames #p"../" (make-pathname :name nil :type nil :version nil :defaults *load-pathname*))) (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*)) -(defparameter *website-directory* (merge-pathnames #p"website/" *root-directory*)) +(defparameter *website-directory* (probe-file (merge-pathnames #p"website/" *root-directory*))) (defparameter *webserver-port* 8080) 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 Tue Jan 29 07:19:19 2008 @@ -5,40 +5,38 @@ (defclass javascript-handler () ()) -(defmethod handle :around ((handler javascript-handler) req) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) - (format *html-stream* "<script language=\"JavaScript\">~%") - (call-next-method) - (format *html-stream* "~%</script>~%")))) +(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>~%")))) (defclass random-image-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler random-image-handler) req) - (random-elt (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler req))))) +(defmethod object-handler-get-object ((handler random-image-handler)) + (random-elt (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler))))) -(defmethod handle-object ((handler random-image-handler) store-image req) - (redirect (format nil "/image/~A" (store-object-id store-image)) req)) +(defmethod handle-object ((handler random-image-handler) store-image) + (redirect (format nil "/image/~A" (store-object-id store-image)))) (defclass animation-handler (object-handler) ()) -(defmethod handle-object ((handler animation-handler) animation req) +(defmethod handle-object ((handler animation-handler) animation) (let ((content-type (blob-type (quickhoney-animation-image-animation animation)))) - (with-bknr-http-response (req :content-type content-type) - (with-http-body (req *ent*) + (with-http-response (:content-type content-type) + (with-http-body () (blob-to-stream (quickhoney-animation-image-animation animation) *html-stream*))))) (defclass image-query-js-handler (javascript-handler object-handler) ()) -(defmethod object-handler-get-object ((handler image-query-js-handler) req) +(defmethod object-handler-get-object ((handler image-query-js-handler)) (sort (remove-if-not #'(lambda (object) (subtypep (type-of object) 'quickhoney-image)) - (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler req)))) + (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler)))) #'< :key #'blob-timestamp)) (defmethod image-to-javascript ((image quickhoney-image) &optional stream) @@ -63,9 +61,9 @@ (format t " ]~@[,~]~%" (cdr page-rest))) (format t "]~%"))) -(defmethod handle-object ((handler image-query-js-handler) images req) +(defmethod handle-object ((handler image-query-js-handler) images) (format *html-stream* "parent.process_query_result(~%") - (with-query-params (req layout) + (with-query-params (layout) (princ (layout-to-javascript (make-instance (case (make-keyword-from-string layout) (:smallworld 'quickhoney-name-layout) (t 'quickhoney-standard-layout)) @@ -75,15 +73,15 @@ (defclass login-js-handler (javascript-handler page-handler) ()) -(defmethod handle ((handler login-js-handler) req) +(defmethod handle ((handler login-js-handler)) (format *html-stream* "parent.login_complete(~A, ~S);~%" - (if (admin-p (bknr-request-user req)) "true" "false") - (user-login (bknr-request-user req)))) + (if (admin-p (bknr-request-user)) "true" "false") + (user-login (bknr-request-user)))) (defclass clients-js-handler (javascript-handler page-handler) ()) -(defmethod handle ((handler clients-js-handler) req) +(defmethod handle ((handler clients-js-handler)) (let ((clients (sort (remove "" (all-clients) :test #'equal) #'string-lessp))) (format *html-stream* "parent.set_clients([~S~{, ~S~}]);~%" @@ -93,15 +91,15 @@ () (:default-initargs :object-class 'quickhoney-image)) -(defmethod handle-object-form ((handler edit-image-js-handler) action image req) +(defmethod handle-object-form ((handler edit-image-js-handler) action image) (format t "; invalid action ~A or invalid object ~A~%" action image)) -(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :edit)) image req) - (with-query-params (req client) +(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()~%"))) -(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :delete)) (image quickhoney-image) req) +(defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :delete)) (image quickhoney-image)) (delete-object image) (format *html-stream* "parent.image_deleted();~%")) @@ -134,9 +132,9 @@ for subcategory = (make-keyword-from-string subcategory-string) collect (list category subcategory (button-for-category category subcategory background-color)))))) -(defmethod handle ((handler buttons-js-handler) req) +(defmethod handle ((handler buttons-js-handler)) (format *html-stream* "var buttons = [];~%") - (loop for (category subcategory image-url) in (find-button-images (decoded-handler-path handler req)) + (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);~%")) @@ -144,10 +142,10 @@ (defclass upload-image-handler (admin-only-handler prefix-handler) ()) -(defmethod handle ((handler upload-image-handler) req) - (with-query-params (req client) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car))) - (keywords (mapcar #'make-keyword-from-string (decoded-handler-path handler req)))) +(defmethod handle ((handler upload-image-handler)) + (with-query-params (client) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car))) + (keywords (mapcar #'make-keyword-from-string (decoded-handler-path handler)))) (handler-case (progn (unless uploaded-file @@ -166,8 +164,8 @@ :class-name 'quickhoney-image :keywords (cons :upload keywords) :initargs `(:client ,client)))) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Upload successful") @@ -179,8 +177,8 @@ :width (round (* ratio width)) :height (round (* ratio height))))) (:p ((:a :href "javascript:done()") "ok"))))))))))) (error (e) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Error during upload")) @@ -193,9 +191,9 @@ (defclass upload-animation-handler (admin-only-handler page-handler) ()) -(defmethod handle ((handler upload-animation-handler) req) - (with-query-params (req client) - (let* ((uploaded-files (request-uploaded-files req :all-info t)) +(defmethod handle ((handler upload-animation-handler)) + (with-query-params (client) + (let* ((uploaded-files (request-uploaded-files :all-info t)) (uploaded-image (find "image-file" uploaded-files :test #'equal :key #'upload-name)) (uploaded-animation (find "animation-file" uploaded-files :test #'equal :key #'upload-name))) (handler-case @@ -211,8 +209,8 @@ :class-name 'quickhoney-animation-image :keywords (list :upload :pixel :animation) :initargs `(:client ,client :animation ,animation-blob)))) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Upload successful") @@ -223,8 +221,8 @@ (:p ((:img :src (format nil "/image/~D" (store-object-id image))))) (:p ((:a :href "javascript:done()") "ok")))))))))) (error (e) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Error during upload")) @@ -237,9 +235,9 @@ (defclass upload-button-handler (admin-only-handler page-handler) ()) -(defmethod handle ((handler upload-button-handler) req) - (with-query-params (req directory subdirectory) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) +(defmethod handle ((handler upload-button-handler)) + (with-query-params (directory subdirectory) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (handler-case (progn (unless (and directory @@ -257,8 +255,8 @@ (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))))) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Upload successful") @@ -270,8 +268,8 @@ :width 208 :height 208))) (:p ((:a :href "javascript:done()") "ok")))))))))) (error (e) - (with-http-response (req *ent*) - (with-http-body (req *ent*) + (with-http-response () + (with-http-body () (html (:html (:head (:title "Error during upload")) Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Tue Jan 29 07:19:19 2008 @@ -13,8 +13,6 @@ (unless (class-instances 'bknr.cron::cron-job) (bknr.cron:make-cron-job "daily statistics" 'make-yesterdays-statistics 1 0 :every :every) (bknr.cron:make-cron-job "snapshot" 'snapshot-store 0 5 :every :every)) + #+cmu (actor-start (make-instance 'cron-actor)) (publish-quickhoney)) - -(eval-when (load) - (startup)) Modified: branches/trunk-reorg/projects/quickhoney/src/layout.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/layout.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/layout.lisp Tue Jan 29 07:19:19 2008 @@ -90,15 +90,18 @@ (defclass item-cell (image-cell) ((item :initarg :item :reader cell-item))) +#+(or) (defmethod cell-image ((cell item-cell)) (item-poster-image (cell-item cell))) +#+(or) (defmethod cell-keywords ((cell item-cell)) (item-image-keywords (cell-item cell))) (defmethod cell-name ((cell item-cell)) (string-downcase (symbol-name (object-name (cell-item cell))))) +#+(or) (defmethod cell-caption ((cell item-cell)) (article-subject (cell-item cell))) @@ -472,7 +475,7 @@ (make-instance 'item-cell :layout layout :item item)) (defun make-item-url (index) - (format nil "~a/~(~a~)" (request-variable :template-path) (object-name (nth index (session-variable :current-query-result))))) + (format nil "~a/~(~a~)" (request-variable :template-path) (object-name (nth index (session-value :current-query-result))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -481,8 +484,8 @@ (defun reorder-query-result () "reorder the query result in the session so that it reflects the order in the layout." - (setf (session-variable :current-query-result) - (loop for page in (layout-pages (session-variable :current-thumbnail-layout)) + (setf (session-value :current-query-result) + (loop for page in (layout-pages (session-value :current-thumbnail-layout)) append (loop for row in (page-rows page) append (row-objects row))))) @@ -498,8 +501,3 @@ (list :affinity 'keyword-affinity-layout) (list :shop 'shop-layout) (list :no 'no-layout))) - -(defun show-session-variables (function-name) - (format t ";; in ~a~%" function-name) - (loop for key being the hash-keys of (bknr-session-variables *session*) - do (format t ";; ~a => ~a~%" key (session-variable key)))) Modified: branches/trunk-reorg/projects/quickhoney/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/packages.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/packages.lisp Tue Jan 29 07:19:19 2008 @@ -20,9 +20,10 @@ (defpackage :quickhoney (:use :cl :cl-user - :ext + :alexandria :cl-interpol :cl-ppcre + :hunchentoot :bknr.utils :bknr.web :bknr.user @@ -31,22 +32,18 @@ :bknr.images :bknr.rss :quickhoney.config - :net.aserve :xhtml-generator) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) + (:shadowing-import-from :alexandria #:array-index) (:export #:last-image-upload-timestamp)) (defpackage :quickhoney.tags (:use :cl :cl-user - :ext :bknr.web :xhtml-generator :bknr.utils :quickhoney :quickhoney.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) (:export #:client-selectbox)) Modified: branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd (original) +++ branches/trunk-reorg/projects/quickhoney/src/quickhoney.asd Tue Jan 29 07:19:19 2008 @@ -16,7 +16,14 @@ :description "worldpay test web server" :long-description "" - :depends-on (:cl-interpol :cl-ppcre :aserve :cxml :mime :bknr :bknr-modules :cl-gd) + :depends-on (:cl-interpol + :cl-ppcre + :cxml + :cl-mime + :bknr-web + :bknr-datastore + :bknr-modules + :cl-gd) :components ((:file "packages") (:file "config" :depends-on ("packages")) Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Tue Jan 29 07:19:19 2008 @@ -6,11 +6,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun publish-quickhoney (&key (port *webserver-port*) (listeners 20)) - - (unpublish :all t) +(defun publish-quickhoney (&key (port *webserver-port*)) (setf bknr.web::*upload-file-size-limit* (* 30 1024 1024)) + (unpublish) (make-instance 'website :name "Quickhoney CMS" :handler-definitions `(("/random-image" random-image-handler) @@ -31,9 +30,9 @@ :command-packages ((:quickhoney . :quickhoney.tags) (:bknr . :bknr.web))) ("/static" directory-handler - :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*))) + :destination ,(merge-pathnames #p"static/" *website-directory*)) ("/favicon.ico" file-handler - :destination ,(unix-namestring (merge-pathnames #p"static/favicon.ico" *website-directory*)) + :destination ,(merge-pathnames #p"static/favicon.ico" *website-directory*) :content-type "application/x-icon")) :modules '(user images) :admin-navigation '(("user" . "/user/") @@ -46,4 +45,4 @@ :style-sheet-urls '("/static/styles.css") :javascript-urls '("/static/javascript.js")) - (start :port port :listeners listeners)) + (hunchentoot:start-server :port port)) Modified: branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp (original) +++ branches/trunk-reorg/projects/raw-data/mcp/handlers.lisp Tue Jan 29 07:19:19 2008 @@ -18,8 +18,8 @@ (defclass sensor-status-handler (page-handler) ()) -(defmethod handle ((handler sensor-status-handler) req) - (with-bknr-page (req :title "RAW DATA Sensor Status") +(defmethod handle ((handler sensor-status-handler)) + (with-bknr-page (:title "RAW DATA Sensor Status") ((:table :border "1") ((:tr :style "background-color: #cccccc;") (:td "Name") (:td "Current") (:td "Age")) Modified: branches/trunk-reorg/projects/raw-data/mcp/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/raw-data/mcp/packages.lisp (original) +++ branches/trunk-reorg/projects/raw-data/mcp/packages.lisp Tue Jan 29 07:19:19 2008 @@ -315,7 +315,6 @@ :cl-interpol :cl-ppcre :bknr.web - :net.aserve :xhtml-generator :mcp.config :mcp.sensors Modified: branches/trunk-reorg/projects/saugnapf/src/package.lisp ============================================================================== --- branches/trunk-reorg/projects/saugnapf/src/package.lisp (original) +++ branches/trunk-reorg/projects/saugnapf/src/package.lisp Tue Jan 29 07:19:19 2008 @@ -44,7 +44,7 @@ :bknr.images :saugnapf.config - :net.aserve + :hunchentoot :xhtml-generator :saugnapf.tags Modified: branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp ============================================================================== --- branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp (original) +++ branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp Tue Jan 29 07:19:19 2008 @@ -27,16 +27,16 @@ (defclass saugnapf-track-handler (edit-object-handler) ()) -(defmethod object-handler-get-object ((handler saugnapf-track-handler) req) - (let ((id-or-name (parse-url req))) +(defmethod object-handler-get-object ((handler saugnapf-track-handler)) + (let ((id-or-name (parse-url))) (when id-or-name (find-store-object id-or-name :class 'saugnapf-track :query-function #'s-track-with-name)))) -(defmethod authorized-p ((handler saugnapf-track-handler) req) - (let* ((track (object-handler-get-object handler req)) - (user (bknr-request-user req)) - (action (query-param req "action")) +(defmethod authorized-p ((handler saugnapf-track-handler)) + (let* ((track (object-handler-get-object handler)) + (user (bknr-request-user)) + (action (query-param "action")) (action-keyword (when action (make-keyword-from-string action)))) (cond ((anonymous-p user) nil) ((admin-p user) t) @@ -47,8 +47,8 @@ ((eql action-keyword :create) t) (t nil)))) -(defmethod handle-object-form ((handler saugnapf-track-handler) action (track (eql nil)) req) - (with-bknr-page (req :title "Manage tracks") +(defmethod handle-object-form ((handler saugnapf-track-handler) action (track (eql nil))) + (with-bknr-page (:title "Manage tracks") ((:form :method "POST") (:h2 "Search for track") "Name: " ((:input :type "text" :name "name" :size "30")) :br @@ -57,34 +57,34 @@ (:h2 "Create new track") (track-form))) -(defmethod handle-object-form ((handler saugnapf-track-handler) action (track saugnapf-track) req) - (with-bknr-page (req :title #?"track $((saugnapf-track-name track))") +(defmethod handle-object-form ((handler saugnapf-track-handler) action (track saugnapf-track)) + (with-bknr-page (:title #?"track $((saugnapf-track-name track))") (track-form :track-id (store-object-id track)))) -(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :save)) track req) +(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :save)) track) (when track - (with-query-params (req name artist url description) + (with-query-params (name artist url description) (change-slot-values track 'artist artist 'name name 'description description 'url url))) (call-next-method)) -(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :delete)) track req) +(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :delete)) track) (when track (delete-object track)) - (redirect "/track" req)) + (redirect "/track")) -(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :create)) track req) - (with-query-params (req name artist url description) +(defmethod handle-object-form ((handler saugnapf-track-handler) (action (eql :create)) track) + (with-query-params (name artist url description) (let ((track (make-object 'saugnapf-track :name name :artist artist :description description :url url - :submitter (bknr-request-user req) + :submitter (bknr-request-user) :date (get-universal-time)))) - (redirect (edit-object-url track) req)))) + (redirect (edit-object-url track))))) (define-bknr-webserver-module saugnapf-track ("/track" saugnapf-track-handler))

1 0

[bknr-cvs] r2416 - branches/trunk-reorg/projects/scrabble/website
by hhubner＠common-lisp.net 29 Jan '08

29 Jan '08

Author: hhubner Date: Tue Jan 29 07:08:08 2008 New Revision: 2416 Added: branches/trunk-reorg/projects/scrabble/website/scrabble-yui-pos.js Log: save this file just in case Added: branches/trunk-reorg/projects/scrabble/website/scrabble-yui-pos.js ============================================================================== --- (empty file) +++ branches/trunk-reorg/projects/scrabble/website/scrabble-yui-pos.js Tue Jan 29 07:08:08 2008 @@ -0,0 +1,168 @@ +// -*- Java -*- (really Javascript) + +var boardScoring = [["triple-word",null,null,"double-letter",null,null,null,"triple-word", + null,null,null,"double-letter",null,null,"triple-word"], + [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter", + null,null,null,"double-word",null], + [null,null,"double-word",null,null,null,"double-letter",null,"double-letter", + null,null,null,"double-word",null,null], + ["double-letter",null,null,"double-word",null,null,null,"double-letter", + null,null,null,"double-word",null,null,"double-letter"], + [null,null,null,null,"double-word",null,null,null,null,null,"double-word", + null,null,null,null], + [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter", + null,null,null,"triple-letter",null], + [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter", + null,null,null,"double-letter",null,null], + ["triple-word",null,null,"double-letter",null,null,null,"double-word", + null,null,null,"double-letter",null,null,"triple-word"], + [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter", + null,null,null,"double-letter",null,null], + [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter", + null,null,null,"triple-letter",null], + [null,null,null,null,"double-word",null,null,null,null,null,"double-word", + null,null,null,null], + ["double-letter",null,null,"double-word",null,null,null,"double-letter", + null,null,null,"double-word",null,null,"double-letter"], + [null,null,"double-word",null,null,null,"double-letter",null,"double-letter", + null,null,null,"double-word",null,null], + [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter", + null,null,null,"double-word",null], + ["triple-word",null,null,"double-letter",null,null,null,"triple-word", + null,null,null,"double-letter",null,null,"triple-word"]]; + +function getFieldScore(x, y) { + return boardScoring[x][y] || 'standard'; +} + +var board; + +function makeBoard() { + var container = $('playfield'); + board = []; + for (x = 0; x < 15; x++) { + board[x] = []; + for (y = 0; y < 15; y++) { + var element = DIV(); + element.style.position = 'absolute'; + element.style.width = '40px'; + element.style.height = '40px'; + element.style.backgroundImage = 'url(images/' + getFieldScore(x, y) + '.png)'; + board[x][y] = element; + appendChildNodes(container, element); + YAHOO.util.Dom.setXY(element, [ x * 44, y * 44 ]); + } + } + + myTrayContainer = DIV(); + myTrayContainer.style.position = 'absolute'; + myTrayContainer.style.width = 7 * 44 + 'px'; + myTrayContainer.style.height = '44px'; + appendChildNodes(container, myTrayContainer); + YAHOO.util.Dom.setXY(myTrayContainer, [ 194, 665 ]); + + var shuffleButton = DIV(null, "shuffle"); + shuffleButton.style.color = 'white'; + shuffleButton.style.position = 'absolute'; + shuffleButton.onclick = shuffleMyTray; + appendChildNodes(container, shuffleButton); + YAHOO.util.Dom.setXY(shuffleButton, [ 480, 665 ]); + + var clearButton = DIV({ id: 'clear' }, "clear"); + clearButton.style.color = 'white'; + clearButton.style.position = 'absolute'; + clearButton.onclick = clearBoard; + appendChildNodes(container, clearButton); + YAHOO.util.Dom.setXY(clearButton, [ 480, 680 ]); + +} + +function setLetter(x, y, letter) { + var image = IMG({ src: 'images/' + letter + '.png'}); + image.style.position = 'absolute'; + image.style.top = '3px'; + image.style.left = '3px'; + replaceChildNodes(board[x][y], image); + board[x][y].letterNode = image; +} + +function clearBoard() { + for (x = 0; x < 15; x++) { + for (y = 0; y < 15; y++) { + var letterNode = board[x][y].letterNode; + if (letterNode) { + board[x][y].letterNode = null; + letterNode.anim = new YAHOO.util.Motion(letterNode, { points: { to: [ 7 * 44 + 3, 7 * 44 + 3 ]}}); + letterNode.anim.duration = 0.15; + letterNode.anim.onComplete.subscribe(function () { removeElement(this); }); + letterNode.anim.animate(); + } + } + } +} + +var tray; + +function trayClick(letter) { + this.clicked = !this.clicked; + this.anim = new YAHOO.util.Motion(this, { points: { by: [ 0, (this.clicked ? 15 : -15 ) ]}}); + this.anim.duration = 0.15; + this.anim.animate(); +} + +function makeMyTray(letters) { + tray = []; + for (var i = 0; i < letters.length; i++) { + var element = IMG({src: 'images/' + letters[i] + '.png'}); + element.letter = letters[i]; + element.style.position = 'absolute'; + element.style.width = '34px'; + element.style.height = '34px'; + element. + onclick = trayClick; + setElementPosition(element, { x: i * 40 }); + tray[i] = element; + } + replaceChildNodes(myTrayContainer, tray); +} + +function shuffleMyTray() { + var count = tray.length; + var newTray = []; + for (var i = 0; i < count; i++) { + do { + index = Math.floor(Math.random() * count); + } while (newTray[index]); + newTray[index] = tray[i]; + newTray[index].anim = new YAHOO.util.Motion(tray[i], { points: { to: [ 194 + i * 40, 680 ] }}); + newTray[index].anim.duration = 0.5; + newTray[index].anim.animate(); + newTray[index].clicked = false; + } + tray = newTray; +} + +function drawGameState (gameState) { + for (var i = 0; i < gameState.board.length; i++) { + var x = gameState.board[i][0]; + var y = gameState.board[i][1]; + var char = gameState.board[i][2]; + setLetter(x, y, char); + } +} + +function init() { + makeBoard(); + makeMyTray(['S', 'A', 'C', 'H', 'D', 'E', 'N']); + setLetter(7, 7, 'H'); + setLetter(7, 8, 'A'); + setLetter(7, 9, 'L'); + setLetter(7, 10, 'L'); + setLetter(7, 11, 'O'); + setLetter(8, 7, 'O'); + setLetter(9, 7, 'R'); + setLetter(10, 7, 'S'); + setLetter(11, 7, 'T'); + var d = loadJSONDoc("/game/108"); + d.addCallbacks(drawGameState, alert); +}

1 0

[bknr-cvs] r2415 - in branches/trunk-reorg/thirdparty: cl-smtp parenscript/src portableaserve split-sequence usocket-0.3.5 usocket-0.3.5/backend usocket-0.3.5/doc usocket-0.3.5/notes usocket-0.3.5/test
by hhubner＠common-lisp.net 29 Jan '08

29 Jan '08

Author: hhubner Date: Tue Jan 29 07:06:27 2008 New Revision: 2415 Added: branches/trunk-reorg/thirdparty/cl-smtp/ branches/trunk-reorg/thirdparty/cl-smtp/CHANGELOG branches/trunk-reorg/thirdparty/cl-smtp/INSTALL branches/trunk-reorg/thirdparty/cl-smtp/LGPL-LICENSE branches/trunk-reorg/thirdparty/cl-smtp/LLGPL-LICENSE branches/trunk-reorg/thirdparty/cl-smtp/README branches/trunk-reorg/thirdparty/cl-smtp/attachments.lisp branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.asd branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.lisp branches/trunk-reorg/thirdparty/cl-smtp/index.html branches/trunk-reorg/thirdparty/cl-smtp/mime-types.lisp branches/trunk-reorg/thirdparty/cl-smtp/style.css branches/trunk-reorg/thirdparty/split-sequence/ branches/trunk-reorg/thirdparty/split-sequence/README.cCLan-install branches/trunk-reorg/thirdparty/split-sequence/split-sequence.asd branches/trunk-reorg/thirdparty/split-sequence/split-sequence.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/ branches/trunk-reorg/thirdparty/usocket-0.3.5/LICENSE branches/trunk-reorg/thirdparty/usocket-0.3.5/Makefile branches/trunk-reorg/thirdparty/usocket-0.3.5/README branches/trunk-reorg/thirdparty/usocket-0.3.5/TODO branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/allegro.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/armedbear.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/clisp.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/cmucl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/lispworks.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/sbcl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/scl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/condition.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/ branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/backends.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/design.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/abcl-socket.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/active-sockets-apis.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/address-apis.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/allegro-socket.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/clisp-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/cmucl-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/errors.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/lw-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/openmcl-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/sb-bsd-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/usock-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/package.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/run-usocket-tests.sh (contents, props changed) branches/trunk-reorg/thirdparty/usocket-0.3.5/test/ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/abcl.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/allegro.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/clisp.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/cmucl.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/package.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/test/sbcl.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/test-usocket.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket-test.asd branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd (contents, props changed) branches/trunk-reorg/thirdparty/usocket-0.3.5/test/your-lisp.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.asd branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.lisp Removed: branches/trunk-reorg/thirdparty/portableaserve/ Modified: branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp Log: update and add packages to replace portableaserve Added: branches/trunk-reorg/thirdparty/cl-smtp/CHANGELOG ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/CHANGELOG Tue Jan 29 07:06:27 2008 @@ -0,0 +1,85 @@ +Version 20071113.1 +2007.11.13 +Add SSL support, thank Timothy Ritchey for the suggestions. +New boolean keyword argument ssl added to send-email. +Change cl-smtp.lisp, cl-smtp.asd, README, CHANGELOG + +Version 20071104.1 +2007.11.04 +Fixed bug with the file attachments to solve corrupted files when +processed with chunking turned on. (Brian Sorg) +Added automatically including mime types for attachesments +of common known extensions. (Brian Sorg) +Added Html-messages option to send-mail function. (Brian Sorg) +Change attachments.lisp, cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG +Add mime-type.lisp + +Version 20071018.1 +2007.10.18 +Reverted the non allegro base64 functionality in attachment.lisp, +now it is used cl-base64 again. Thanks Attila Lendvai for the bug report. +Change attachments.lisp, cl-smtp.asd, CHANGELOG + +Version 20070904.1 +2007-09-04 +Remove implementation dependent sockets code by adding usocket dependency. +Change cl-smtp.asd cl-smtp.lisp README INSTALL + (remove acl.lisp clisp.lisp cmucl.lisp sbcl.lisp lispworks.lisp openmcl.lisp) + +Version 20060404.1 +2006-04-04 +"ADD" support for attachment, thanks Brian Sorg for the implementation +Added attachments.lisp +Change cl-smtp.asd cl-smtp.lisp README + +Version 20051220.1 +2005-12-20 +"ADD" win32 support for clisp +"REMOVE" :cl-smtp-authentication +"CHANGE" always use CL-BASE64 package +Change cl-smtp.asd, cl-smtp.lisp, clisp.lisp, README, CHANGELOG + +Version 20051211.1 +2005-12-11 +"ADD" :cl-smtp-authentication for reader macro, that you can use cl-smtp with and +without authentication support +Change cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG + +Version 20051210.1 +2005-12-10 +"ADD" key authentication for smtp authentication: '(:plain "username" "password") +or '(:login "username" "password") +add dependency to CL-BASE64 except allegro +Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG + +Version 20050729.1 +2005-07-29 +"CHANGE" license from LGPL to LLGPL +"ADD" key display-name for optional display name of the from email adress +(RFC 2822 3.4. Address Specification) +Added LLGPL-LICENSE +Change all files + +Version 20050127.1 +2005-01-27 +"FIXED" add correct multiline replies in read-from-smtp (RFC 822 APPENDIX E) +"ADD" key extra-headers to send-email, send-smtp +thanks Dave Bakkash to inform me about the wrong implemantation +of read-from-smtp and the tip with the extra-headers +Change cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG + +Version 20050119.1 +2005-01-19 +Add portability file "lispworks.lisp" to work with Lispworks, +thanks Sean Ross for this file +Added lispworks.lisp +Change cl-smtp.asd, README, INSTALL, CHANGELOG + +Version 20050104.1 +2005-01-04 +"Fixed" month "Sep" missed in get-email-date-string +Added this CHANGELOG + +Version 20040812.1 +2004-08-12 +Initial release Added: branches/trunk-reorg/thirdparty/cl-smtp/INSTALL ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/INSTALL Tue Jan 29 07:06:27 2008 @@ -0,0 +1,13 @@ + +CL-SMTP works in all implementations supported by its dependencies. + +For all implementations you'll need usocket +and cl-base64 (the latter isn't a requirement on ACL). + +CL-SMTP has a asdf system definition file. + +To load this file: + +(asdf:operate 'asdf:load-op 'cl-smtp) + +thats all. Added: branches/trunk-reorg/thirdparty/cl-smtp/LGPL-LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/LGPL-LICENSE Tue Jan 29 07:06:27 2008 @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + Added: branches/trunk-reorg/thirdparty/cl-smtp/LLGPL-LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/LLGPL-LICENSE Tue Jan 29 07:06:27 2008 @@ -0,0 +1,18 @@ + + +Preamble to the Gnu Lesser General Public License + + +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been adopted to govern the use and distribution of above-mentioned application. However, the LGPL uses terminology that is more appropriate for a program written in C than one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if certain clarifications are made. This document details those clarifications. Accordingly, the license for the open-source Lisp applications consists of this document plus the LGPL. Wherever there is a conflict between this document and the LGPL, this document takes precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. The form of the Library can be Lisp source code (for processing by an interpreter) or object code (usually the result of compilation of source code or built with some other mechanisms). Foreign modules are object code in a form that can be linked into a Lisp executable. When we speak of functions we do so in the most general way to include, in addition, methods and unnamed functions. Lisp "data" is also a general term that includes the data structures resulting from defining Lisp classes. A Lisp application may include the same set of Lisp objects as does a Library, but this does not mean that the application is necessarily a "work based on the Library" it contains. + +The Library consists of everything in the distribution file set before any modifications are made to the files. If any of the functions or classes in the Library are redefined in other files, then those redefinitions ARE considered a work based on the Library. If additional methods are added to generic functions in the Library, those additional methods are NOT considered a work based on the Library. If Library classes are subclassed, these subclasses are NOT considered a work based on the Library. If the Library is modified to explicitly call other functions that are neither part of Lisp itself nor an available add-on module to Lisp, then the functions called by the modified Library ARE considered a work based on the Library. The goal is to ensure that the Library will compile and run without getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it must be done in a way such that the Library will still run without that proprietary code present. Section 5 of the LGPL distinguishes between the case of a library being dynamically linked at runtime and one being statically linked at build time. Section 5 of the LGPL states that the former results in an executable that is a "work that uses the Library." Section 5 of the LGPL states that the latter results in one that is a "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only offers one choice, which is to link the Library into an executable at build time, we declare that, for the purpose applying the LGPL to the Library, an executable that results from linking a "work that uses the Library" with the Library is considered a "work that uses the Library" and is therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to the Library. However, in connection with each distribution of this executable, you must also deliver, in accordance with the terms and conditions of the LGPL, the source code of Library (or your derivative thereof) that is incorporated into this executable. + +End of Document \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-smtp/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/README Tue Jan 29 07:06:27 2008 @@ -0,0 +1,61 @@ + +CL-SMTP is a simple lisp smtp client. +It works in ACL, SBCL, CMUCL, OPENMCL, LISPWORKS, CLISP and ECL. + +new with support for send attachments, thanks Brian Sorg for the implementation + +with authentication support for PLAIN and LOGIN authentication method + +and ssl support with cl+ssl package + +used cl-base64 and usocket packages (cl-base64 isn't a requirement on ACL) + +See INSTALL for prerequisites and build details. + +To use cl-smtp: + +(asdf:operate 'asdf:load-op 'cl-smtp) + +------------------------------------------------ + +(cl-smtp:send-email host from to subject message + &key (port 25) cc bcc reply-to extra-headers html-message + authentication attachments (buffer-size 256) ssl) + + Arguments: + - host (String) : hostname or ip-adress of the smtpserver + - from (String) : email adress + - to (String or Cons of Strings) : email adress + - subject (String) : subject text + - message (String) : message body + keywords: + - cc (String or Cons of Strings) : email adress carbon copy + - bcc (String or Cons of Strings): email adress blind carbon copy + - reply-to (String) : email adress + - displayname (String) : displayname of the sender + - extra-headers (Cons) : extra headers as alist + - html-message (String) : message body formatted with HTML tags + - authentication (Cons) : list with 3 elements + (:method "username" "password") + method is a keyword :plain or :login + - attachments (String or Pathname: attachments to send + Cons of String/Pathnames) + - buffer-size (Number default 256): controls how much of a attachment file + is read on each loop before encoding + and transmitting the contents, + the number is interpretted in KB + - ssl (Boolean) : if true than use the STARTTLS functionality to make a ssl connection + +Returns nil or error with message + +For debug output set the parameter *debug* to t (default nil) +(setf cl-smtp::*debug* t) + +CL-SMTP set automaticly the Date header and the X-Mailer header. +X-Mailer: cl-smtp ((lisp-implementation-type) (lisp-implementation-version)) + +You can change this with setting the parameter *x-mailer* +(setf cl-smtp::*x-mailer* "my x-mailer string) + +If you find bugs or want to send patches for enhancements, by email to +Jan Idzikowski <jidzikowski(a)common-lisp.net> Added: branches/trunk-reorg/thirdparty/cl-smtp/attachments.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/attachments.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,167 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html) known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: attachments.lisp +;;; Description: encoding and transmitting login to include a mime attachment + +;;; +;;; Contributed by Brian Sorg +;;; +;;; Thanks to David Cooper for make-random-boundary +;;; +(in-package :cl-smtp) + +;;; Addition to allow for sending mime attachments along with the smtp message + +;;---- Initialize array of possible boundary characters to make start of attachments +(defparameter *boundary-chars* + (let* ((chars (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z + #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z + #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (arr (make-array (length chars)))) + (dotimes (i (length chars) arr) + (setf (aref arr i) (pop chars))))) + +(defun make-random-boundary (&optional (length 30) + (boundary-chars *boundary-chars*)) + (let ((boundary (make-string length)) + (prefix "_---------_") + (chars-length (length boundary-chars))) + (dotimes (i length (concatenate 'string prefix boundary)) + (setf (aref boundary i) + (svref *boundary-chars* (random chars-length)))))) + +(defun generate-multipart-header (sock boundary &key (multipart-type "mixed")) + (write-to-smtp sock + (format nil "Content-type: multipart/~a;~%~tBoundary=\"~a\"" + multipart-type boundary))) + +(defun generate-message-header (sock + &key boundary ;; uniques string of character -- see make-random-boundary + content-type ;; "text/plain; charset=ISO-8859-1" + content-disposition ;; inline attachment + content-transfer-encoding ;; 7 bit or 8 bit + (include-blank-line? t)) + (when boundary + (write-to-smtp sock (format nil "--~a" boundary))) + (when content-type + (write-to-smtp sock (format nil "Content-type: ~a" content-type))) + (when content-disposition + (write-to-smtp sock (format nil "Content-Disposition: ~A" + content-disposition))) + (when content-transfer-encoding + (write-to-smtp sock (format nil "Content-Transfer-Encoding: ~A" + content-transfer-encoding))) + (when include-blank-line? (write-blank-line sock))) + +(defun send-attachment-header (sock boundary name) + + (generate-message-header + sock + :boundary boundary + :content-type (format nil "~a;~%~tname=\"~a\"" (lookup-mime-type name) name) + :content-transfer-encoding "base64" + :content-disposition (format nil "attachment; filename=\"~a\"" name))) + +(defun send-end-marker (sock boundary) + ;; Note the -- at beginning and end of boundary is required + (write-to-smtp sock (format nil "~%--~a--~%" boundary))) + +(defun send-attachment (sock attachment boundary buffer-size) + (when (probe-file attachment) + (let ((name (file-namestring attachment))) + (send-attachment-header sock boundary name) + (base64-encode-file attachment sock :buffer-size buffer-size)))) + +(defun base64-encode-file (file-in sock + &key + (buffer-size 256) ;; in KB + (wrap-at-column 70)) + "Encodes the file contents given by file-in, which can be of any form appropriate to with-open-file, and write the base-64 encoded version to sock, which is a socket. + +Buffer-size, given in KB, controls how much of the file is processed and written to the socket at one time. A buffer-size of 0, processes the file all at once, regardless of its size. One will have to weigh the speed vs, memory consuption risks when chosing which way is best. + +Wrap-at-column controls where the encode string is divided for line breaks." + (when (probe-file file-in) + ;;-- open filein --------- + (with-open-file (strm-in file-in + :element-type '(unsigned-byte 8)) + (let* ((;; convert buffer size given to bytes + ;; or compute bytes based on file + max-buffer-size + (if (zerop buffer-size) + (file-length strm-in) + ;; Ensures 64 bit encoding is properly + ;; divided so that filler + ;; characters are not required between chunks + (* 24 (truncate (/ (* buffer-size 1024) 24))))) + (column-count 0) + (eof? nil) + (buffer (make-array max-buffer-size + :element-type '(unsigned-byte 8)))) + (loop + (print-debug (format nil "~%Process attachment ~a~%" file-in)) + (let* ((;; read a portion of the file into the buffer arrary and + ;; returns the index where it stopped + byte-count (dotimes (i max-buffer-size max-buffer-size) + (let ((bchar (read-byte strm-in nil 'EOF))) + (if (eql bchar 'EOF) + (progn + (setq eof? t) + (return i)) + (setf (aref buffer i) bchar)))))) + (if (zerop buffer-size) + ;; send file all at once to socket. + #+allegro + (write-string (excl:usb8-array-to-base64-string + buffer wrap-at-column) sock) + #-allegro + (cl-base64:usb8-array-to-base64-stream + buffer sock :columns wrap-at-column) + ;; otherwise process file in chunks. + ;; The extra encoded-string, + ;; and its subseq functions are brute force methods + ;; to properly handle the wrap-at-column feature + ;; between buffers. + ;; Not the most efficient way, + ;; but it works and uses existing functions + ;; in the cl-base64 package. + (let* ((;; drops off extra elements that were not filled in in reading, this is important for lisp systems that default a value into + ;; the array when it is created. -- ie Lispworks, SBCL + trimmed-buffer (if eof? + (subseq buffer 0 byte-count) + buffer)) + (encoded-string + #+allegro + (excl:usb8-array-to-base64-string + trimmed-buffer) + #-allegro + (cl-base64:usb8-array-to-base64-string + trimmed-buffer))) + (loop for ch across encoded-string + do (progn + (write-char ch sock) + (incf column-count) + (when (= column-count wrap-at-column) + (setq column-count 0) + (write-char #\Newline sock)))))) + (force-output sock) + (print-debug (format nil "~% Eof is ~a~%" eof?)) + (when (or (zerop buffer-size) + eof?) + (return)))))))) Added: branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,40 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html) known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: cl-smtp.asd +;;; Description: cl-smtp ASDF system definition file + +(defpackage :cl-smtp + (:use :cl :asdf) + (:export :send-email)) + +(in-package :cl-smtp) + +(defparameter *debug* nil) + +(defmacro print-debug (str) + `(when *debug* + (print ,str))) + +(asdf:defsystem :cl-smtp + :version "20071113.1" + :perform (load-op :after (op webpage) + (pushnew :cl-smtp cl:*features*)) + :depends-on (:usocket #-allegro :cl-base64 + #-allegro :flexi-streams + #-allegro :cl+ssl) + :components ((:file "cl-smtp" :depends-on ("attachments")) + (:file "attachments") + (:file "mime-types"))) Added: branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,341 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html) known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: cl-smtp.lisp +;;; Description: main smtp client logic + +(in-package :cl-smtp) + +(defparameter *content-type* "text/plain; charset=ISO-8859-1") + +(defparameter *x-mailer* (format nil "(~A ~A)" + (lisp-implementation-type) + (lisp-implementation-version))) + +(defun check-arg (arg name) + (cond + ((or (stringp arg) + (pathnamep arg)) + (list arg)) + ((listp arg) + arg) + (t + (error "the \"~A\" argument is not a string or cons" name)))) + +(defun mask-dot (str) + "replace \r\n.\r\n with \r\n..\r\n" + (let ((dotstr (format nil "~C~C.~C~C" #\Return #\NewLine + #\Return #\NewLine)) + (maskdotsr (format nil "~C~C..~C~C" #\Return #\NewLine + #\Return #\NewLine)) + (resultstr "")) + (labels ((mask (tempstr) + (let ((n (search dotstr tempstr))) + (cond + (n + (setf resultstr (concatenate 'string resultstr + (subseq tempstr 0 n) + maskdotsr)) + (mask (subseq tempstr (+ n 5)))) + (t + (setf resultstr (concatenate 'string resultstr + tempstr))))))) + (mask str)) + resultstr)) + +(defun string-to-base64-string (str) + (declare (ignorable str)) + #+allegro (excl:string-to-base64-string str) + #-allegro (cl-base64:string-to-base64-string str)) + + +(defun send-email (host from to subject message + &key (port 25) cc bcc reply-to extra-headers + html-message display-name authentication + attachments (buffer-size 256) ssl) + (send-smtp host from (check-arg to "to") subject (mask-dot message) + :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc") + :reply-to reply-to + :extra-headers extra-headers + :html-message html-message + :display-name display-name + :authentication authentication + :attachments (check-arg attachments "attachments") + :buffer-size (if (numberp buffer-size) + buffer-size + 256) + :ssl ssl)) + + +(defun send-smtp (host from to subject message + &key (port 25) cc bcc reply-to extra-headers html-message + display-name authentication attachments buffer-size ssl) + (let* ((sock (usocket:socket-stream (usocket:socket-connect host port))) + (boundary (make-random-boundary)) + (html-boundary (if (and attachments html-message) + (make-random-boundary) + boundary))) + (unwind-protect + (let ((stream (open-smtp-connection sock + :authentication authentication + :ssl ssl))) + (send-smtp-headers stream :from from :to to :cc cc :bcc bcc + :reply-to reply-to + :display-name display-name + :extra-headers extra-headers :subject subject) + (when (or attachments html-message) + (send-multipart-headers + stream :attachment-boundary (when attachments boundary) + :html-boundary html-boundary)) + ;;----------- Send the body Message --------------------------- + ;;--- Send the proper headers depending on plain-text, + ;;--- multi-part or html email + (cond ((and attachments html-message) + ;; if both present, start attachment section, + ;; then define alternative section, + ;; then write alternative header + (progn + (generate-message-header + stream :boundary boundary :include-blank-line? nil) + (generate-multipart-header stream html-boundary + :multipart-type "alternative") + (write-blank-line stream) + (generate-message-header + stream :boundary html-boundary :content-type *content-type* + :content-disposition "inline" :include-blank-line? nil))) + (attachments + (generate-message-header + stream :boundary boundary + :content-type *content-type* :content-disposition "inline" + :include-blank-line? nil)) + (html-message + (generate-message-header + stream :boundary html-boundary :content-type *content-type* + :content-disposition "inline")) + (t + (generate-message-header stream :content-type *content-type* + :include-blank-line? nil))) + (write-blank-line stream) + (write-to-smtp stream message) + (write-blank-line stream) + ;;---------- Send Html text if needed ------------------------- + (when html-message + (generate-message-header + stream :boundary html-boundary + :content-type "text/html; charset=ISO-8859-1" + :content-disposition "inline") + (write-to-smtp stream html-message) + (send-end-marker stream html-boundary)) + ;;---------- Send Attachments ----------------------------------- + (when attachments + (dolist (attachment attachments) + (send-attachment stream attachment boundary buffer-size)) + (send-end-marker stream boundary)) + (write-char #\. stream) + (write-blank-line stream) + (force-output stream) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "Message send failed: ~A" msgstr))) + (write-to-smtp stream "QUIT") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 221) + (error "in QUIT command:: ~A" msgstr)))) + (close sock)))) + +(defun open-smtp-connection (stream &key authentication ssl) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 220) + (error "wrong response from smtp server: ~A" msgstr))) + (when ssl + (write-to-smtp stream (format nil "EHLO ~A" + (usocket::get-host-name))) + (multiple-value-bind (code msgstr lines) + (read-from-smtp stream) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr)) + (when ssl + (cond + ((find "STARTTLS" lines :test #'equal) + (print-debug "this server supports TLS") + (write-to-smtp stream "STARTTLS") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 220) + (error "Unable to start TLS: ~A" msgstr)) + (setf stream + #+allegro (socket:make-ssl-client-stream stream) + #-allegro + (let ((s stream)) + (cl+ssl:make-ssl-client-stream + (cl+ssl:stream-fd stream) + :close-callback (lambda () (close s))))) + #-allegro + (setf stream (flexi-streams:make-flexi-stream + stream + :external-format + (flexi-streams:make-external-format + :latin-1 :eol-style :lf))))) + (t + (error "this server does not supports TLS")))))) + (cond + (authentication + (write-to-smtp stream (format nil "EHLO ~A" + (usocket::get-host-name))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr))) + (cond + ((eq (car authentication) :plain) + (write-to-smtp stream (format nil "AUTH PLAIN ~A" + (string-to-base64-string + (format nil "~A~C~A~C~A" + (cadr authentication) + #\null (cadr authentication) + #\null + (caddr authentication))))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 235) + (error "plain authentication failed: ~A" msgstr)))) + ((eq (car authentication) :login) + (write-to-smtp stream "AUTH LOGIN") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 334) + (error "login authentication failed: ~A" msgstr))) + (write-to-smtp stream (string-to-base64-string (cadr authentication))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 334) + (error "login authentication send username failed: ~A" msgstr))) + (write-to-smtp stream (string-to-base64-string (caddr authentication))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 235) + (error "login authentication send password failed: ~A" msgstr)))) + (t + (error "authentication ~A is not supported in cl-smtp" + (car authentication))))) + (t + (write-to-smtp stream (format nil "HELO ~A" (usocket::get-host-name))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr))))) + stream) + +(defun send-smtp-headers (stream + &key from to cc bcc reply-to + extra-headers display-name subject) + (write-to-smtp stream + (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from)) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "in MAIL FROM command: ~A" msgstr))) + (compute-rcpt-command stream to) + (compute-rcpt-command stream cc) + (compute-rcpt-command stream bcc) + (write-to-smtp stream "DATA") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 354) + (error "in DATA command: ~A" msgstr))) + (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) + (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]" + display-name from display-name)) + (write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to)) + (when cc + (write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" cc))) + (write-to-smtp stream (format nil "Subject: ~A" subject)) + (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A" + *x-mailer*)) + (when reply-to + (write-to-smtp stream (format nil "Reply-To: ~A" reply-to))) + (when (and extra-headers + (listp extra-headers)) + (dolist (l extra-headers) + (write-to-smtp stream + (format nil "~A: ~{~a~^,~}" (car l) (rest l))))) + (write-to-smtp stream "Mime-Version: 1.0")) + +(defun send-multipart-headers (stream &key attachment-boundary html-boundary) + (cond (attachment-boundary + (generate-multipart-header stream attachment-boundary + :multipart-type "mixed")) + (html-boundary (generate-multipart-header + stream html-boundary + :multipart-type "alternative")) + (t nil))) + +(defun compute-rcpt-command (stream adresses) + (dolist (to adresses) + (write-to-smtp stream (format nil "RCPT TO:<~A>" to)) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "in RCPT TO command: ~A" msgstr))))) + +(defun write-to-smtp (stream command) + (print-debug (format nil "to server: ~A" command)) + (write-string command stream) + (write-char #\Return stream) + (write-char #\NewLine stream) + (force-output stream)) + +(defun write-blank-line (stream) + (write-char #\Return stream) + (write-char #\NewLine stream) + (force-output stream)) + +(defun read-from-smtp (stream &optional lines) + (let* ((line (read-line stream)) + (response (string-trim '(#\Return #\NewLine) (subseq line 4))) + (response-code (parse-integer line :start 0 :junk-allowed t))) + (print-debug (format nil "from server: ~A" line)) + (if (= (char-code (elt line 3)) (char-code #\-)) + (read-from-smtp stream (append lines (list response))) + (values response-code line lines)))) + +(defun get-email-date-string () + (multiple-value-bind (sec min h d m y wd) (get-decoded-time) + (let* ((month (elt '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1))) + (weekday (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") wd)) + (timezone (get-timezone-from-integer + (- (encode-universal-time sec min h d m y 0) + (get-universal-time))))) + (format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D" + weekday d month y h min sec timezone)))) + +(defun get-timezone-from-integer (x) + (let ((min (/ x 60)) + (hour (/ x 3600))) + (if (integerp hour) + (cond + ((>= hour 0) + (format nil "+~2,'0d00" hour)) + ((< hour 0) + (format nil "-~2,'0d00" (* -1 hour)))) + (multiple-value-bind (h m) (truncate min 60) + (cond + ((>= hour 0) + (format nil "+~2,'0d~2,'0d" h (truncate m))) + ((< hour 0) + (format nil "-~2,'0d~2,'0d" (* -1 h) (* -1 (truncate m))))))))) Added: branches/trunk-reorg/thirdparty/cl-smtp/index.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/index.html Tue Jan 29 07:06:27 2008 @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>CL-SMTP</title> + <link rel="stylesheet" type="text/css" href="style.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> +</head> + +<body> + <div class="header"> + <h1>CL-SMTP at common-lisp.net</h1> + </div> + + <h3>Introduction</h3> + + CL-SMTP is a simple lisp Networking Library that provides SMTP client protocol, supported LOGIN and PLAIN authentication methods. + + New Version [20071018.1] Reverted the non allegro base64 functionality in attachment.lisp, now it is used cl-base64 again. Thanks Attila Lendvai for the bug report. + + <h3>Download</h3> + + ASDF package <a href="cl-smtp.tar.gz">cl-smtp.tar.gz</a> + + <h3>CVS</h3> + + You can <a + href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=cl-smtp"> +browse our CVS repository</a> or download the current development tree via + anonymous cvs, as described <a href="/faq.shtml#checkout">here</a> + + <h3>Portability</h3> + + CL-SMTP requires USOCKET and CL-BASE64 (CL-BASE64 isn't a requirement on ACL) + It works in all implementations supported by its dependencies (Allegro, SBCL, CMU CL, OpenMCL, Lispworks, CLISP and ECL). + Test results for Linux/x86/amd64: + <table cellspacing="0" cellpadding="2" border="1"> + <thead> + <tr> + <th>Lisp Implementation</th> + <th>Status</th> + <th>Comments</th> + </tr> + </thead> + <tr> + <td>Allegro</td> + <td class="working">working</td> + </tr> + <tr> + <td>CLISP</td> + <td class="working">working</td> + </tr> + <tr> + <td>CMU CL</td> + <td class="working">working</td> + </tr> + <tr> + <td>Lispworks</td> + <td class="working">working</td> + </tr> + <tr> + <td>SBCL</td> + <td class="working">working</td> + </tr> + <tr> + <td>OpemMCL</td> + <td class="working">working</td> + </tr> + </table> + + <h3>Mailing Lists</h3> + <ul> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-smtp-devel"> + CL-SMTP-devel</a> for developers</li> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-smtp-cvs"> + CL-SMTP-cvs</a> CVS log feed.</li> + </ul> + + <div class="footer"> + <a href="mailto:jidzikowski (at) common-lisp (dot) net">Jan Idzikowski</a>, 24. May 2005. + </div> + + <div class="check"> + <a href="http://validator.w3.org/check/referer"> + Valid XHTML 1.0 Strict</a> + </div> + </body> +</html> Added: branches/trunk-reorg/thirdparty/cl-smtp/mime-types.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/mime-types.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,556 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html) known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: attachments.lisp +;;; Description: encoding and transmitting login to include a mime attachment + +;;; +;;; Contributed by Brian Sorg +;;; +(in-package :cl-smtp) + +(eval-when (:compile-toplevel :load-toplevel) +;;; Some of the most common file extensions with the mime types and descriptions. +;;; Extracted from numberous webpages. + (defparameter *mime-type-descriptions* + '(("386" "application/octet-stream" + "Windows Enhanced Mode Driver or Swap File") + ("001" "application/x-001" "FAX Datafile") + ("3GPP" "audio/3gpp" + "3rd +Generation Partnership Project. Multimedia over 3rd generation wireless +networks. H.263 video is the mandatory video format in 3GPP and AMR is +the main audio/speech format.") + ("7CB" "application/vnd.ecdis-update" + "Electronic Chart Display and Information System (ECDIS)") + ("aa" "audio/audible" "Audible file format (audio books)") + ("aab" "application/x-authorware-bin" "Macromedia Authorware Binary") + ("aac" "audio/aac" + "Advanced Audio Coding File. Part of MPEG-2 and MPEG-4 standard. (Apple iTunes Store)") + ("aam" "application/x-authorware-map" "Authorware Map (Shockwave?)") + ("aas" "application/x-authorware-seg" + "Authorware Shocked Packet (Segment) ") + ("aba" "text/x-palm-aba" "AddressBook Archive (Palm)") + ("ac3" "audio/ac3" + "Adaptive Transform Coder 3 (relates to the bitstream format of Dolby Digital)") + ("adr" "application/x-msaddr" "Address Book") + ("aexpk" "application/pgp-keys" "Armored extracted public key (PGP)") + ("afl" "video/animaflex" "Font file (for Allways) (Lotus 1-2-3)") + ("ahtml" "magnus-internal/cgi-advertiser" " ") + ("ai" "application/postscript" + "Encapsulated PostScript (metafile) (Adobe Illustrator)") + ("aif" "audio/x-aiff" "Audio Interchange File Format") + ("aifc" "audio/x-aiff" "Audio Interchange File Format") + ("aiff" "audio/x-aiff" "Audio Interchange File Format") + ("aim" "application/x-aim" "AIM file - AOL Instant Messanger") + ("alt" "application/x-up-alert" "Menu file (WordPerfect Library)") + ("aos" "application/x-nokia-" "Add-On Software (Nokia 9000)") + ("arj" "application/x-arj" + "Compressed file archive created by ARJ or winzip") + ("art" "image/x-jg" + "AOL Johnson-Grace Compressed File and Another Ray Tracer Format") + ("asc" "application/pgp-encrypted" "Armored Encrypted file (PGP)") + ("asd" "application/astound" "Autosave file (Word for Windows)") + ("asf" "application/vnd.ms-asf video/x-ms-asf video/x-ms-wm" + "Windows Media file - Advanced Streaming Format (ASF), NetShow") + ("asn" "application/astound" " ") + ("asp" "text/html" + "Active Server Pages - standard HTML documents interlaced with ActiveX script code ") + ("asr" "video/x-ms-asf" "Microsoft NetShow") + ("asx" "video/x-ms-asf application/x-mplayer2" + "VXtreme (Microsoft streaming AV)") + ("asz" "application/astound" " ") + ("au" "audio/basic" "8-bit u-law [PCM] / 8000 Hz") + ("avi" "video/x-msvideo" "Windows Video file") + ("axs" "application/olescript" " ") + ("bas" "text/plain" "BASIC program") + ("bat" "application/octet-stream" "DOS BAT (Batch) file.") + ("bcpio" "application/x-bcpio" "Old Binary CPIO") + ("bexpk" "application/pgp-keys" "binary extracted public key (PGP)") + ("bin" "application/octet-stream" "Uninterpreted Binary Data") + ("bk" "application/vnd.framemaker" "FrameMaker book ") + ("bleep" "application/bleeper" " ") + ("bmp" "image/x-bmp" "Windows Bitmap (PaintBrush)") + ("btf" "image/prs.btf" "NationsBank Check Images (also .btif)") + ("c" "text/plain" "C program") + ("c++" "text/plain" "C program") + ("cab" "application/cab" + "Cabinet file Microsoft installation archive. opersyss=win32, mac cpu=x86, ppc, mips, alpha") + ("cal" "application/x-msschedplus" "MS schedplus or calendar") + ("cat" "application/pdf" + "PDF Catalog (Used with Acrobat Reader and Search plug-in)") + ("cat" "application/vnd.ms-pki.seccat" "Security Catalog") + ("ccs" "text/ccs" + "Cluster Configuration System used with the Global File System (GFS) in Red Hat Linux") + ("cdda" "audio/aiff" "CD Audio Track") + ("cda" "audio/x-cda" "CD Audio Track") + ("cdf" "text/plain" "Channel Definition Format - MS push std") + ("cdr" "application/x-coreldrw" "Corel Draw (metafile)") + ("cer" " application/pkix-cert" "Certificatefile") + ("cfm" "wwwserver/wsapi" "Cold Fusion Markup") + ("cgi" "magnus-internal/cgi" "Common Gateway Interface") + ("cgm" "image/cgm" "Computer Graphics Metafile ") + ("chat" "application/x-chat" " ") + ("che" "application/x-up-cacheop" " ") + ("cht" "audio/x-dspeech" + "Chart (Harvard Graphics 2.0 - SoftCraft Presenter)") + ("cil" "application/vnd.ms-artgalry" "Clip Gallery Download Packages") + ("class" "application/java-vm" "Java") + ("cli" "application/vnd.ms-artgalry" " ") + ("clp" "application/x-msclip" "Windows Clipboard (metafile)") + ("cmx" "image/x-cmx" " ") + ("cnc" "application/x-cnc" "CNC general program data") + ("cod" "image/cis-cod" + "Datafile (Forecast Plus - MS Multiplan - StatPac Gold)") + ("coda" "application/x-coda" " ") + ("com" "application/octet-stream" + "DOS COM Executable (similar to exe, but a direct memory image)") + ("cpi" "image/cpi" "ColorLab Processed Image ") + ("cpio" "application/x-cpio" "IEEE Std1003.2 (`POSIX') CPIO") + ("cpt" "application/mac-compactpro" "Compact Pro Archive") + ("crd" "application/x-mscardfile" "MS cardfile") + ("crt" "application/x-x509-ca-cert" "Certificatefile") + ("csh" "application/x-csh" "CSH Script") + ("csm" "application/x-cu-seeme" "Precompiled headers (Borland C++ 4.5)") + ("css" "text/css" "Cascading Style Sheets") + ("csv" "text/csv" + "Comma-Separated Values (Excel, Lotus 123, FoxPro, MS Outlook)") + ("ct" "image/" "Iris CT Graphic or Scitex CT Handshake Bitmap ") + ("cu" "application/x-cu-seeme" " ") + ("cut" "image/x-halo-cut" "Bitmap graphics") + ("dat" "application/octet-stream" + "Data file. Can be anything, text, graphics, binary, ...") + ("dba" "text/x-palm-dba" "DateBook Archive (Palm)") + ("dbf" "application/octet-stream" "DataBase File (FoxPro, dBase) ") + ("dbm" "wwwserver/wsapi" "ColdFusion IIS Plugin") + ("dca" "application/dca-rft" "IBM Doc Content Arch") + ("dcr" "application/x-director" "Macromedia Director (Shockwave)") + ("deb" "application/octet-stream" "Binary for debian UNIX") + ("der" "application/x-x509-ca-cert" "Certificatefile") + ("dir" "application/x-director" "Macromedia Director (Shockwave)") + ("dll" "application/x-msdownload" + "Dynamically Linked Library (DOS) pe-portable executable opersys=win32, mac cpu=x86, ppc, mips, alpha") + ("dms" "application/octet-stream" + "Compressed Amiga file archive created by DISKMASHER") + ("doc" "application/msword" "MS Word") + ("dot" "application/msword" "MS Word (Template)") + ("dsf" "image/x-mgx-dsf" "Micrografx Designer 6 (metafile)") + ("dst" "application/tajima" "PC-RDist Distribution file ") + ("dtd" "text/xml" "SGML Document (Type) Definition file") + ("dus" "audio/x-dspeech" "Readiris font dictionary") + ("dvi" "application/x-dvi" "TeX DVI (Device Independent)") + ("dwc" "application/dwc" "compressed archive") + ("dwf" "drawing/x-dwf" "Autodesk WHIP! Drawing Web file") + ("dwg" "application/x-acad" "AutoCAD Drawing") + ("dxf" "application/vnd.dxf" + "Drawing eXchange Format, Data Exchange File, AutoCAD (vector)") + ("dxr" "application/x-director" "Macromedia Director (Shockwave)") + ("ebk" "application/x-expandedbook" " ") + ("emf" "image/x-emf" + "Enhanced metafile created in Microsoft Windows and Visio 2002 applications") + ("eml" "message/rfc822" + "MS Internet Mail Message (Outlook Express and others)") + ("enc" "application/pre-encrypted" + "Pre-encrypted Data (also Sniffer trace)") + ("eps" "application/postscript" "Encapsulated PostScript (raster)") + ("erf" "application/x-hsp-erf" " ") + ("es" "audio/echospeech" " ") + ("etf" "image/x-etf" "Enriched Text file") + ("etx" "text/x-setext" "Structure Enchanced Text") + ("evy" "application/x-envoy" "Document (WordPerfect Envoy)") + ("exe" "application/x-pe-" + "pe-portable executable opersys=win32, mac cpu=x86, ppc, mips, alpha") + ("fdf" "application/vnd.fdf" "acrobat reader") + ("fh4" "image/x-freehand" "Vector graphics (Aldus FreeHand 4.x)") + ("fh5" "image/x-freehand" "Freehand 5") + ("fhc" "image/x-freehand" "Freehand") + ("fif" "image/fif" "Fractal Image Format file") + ("fla" "application/x-shockwave-flash" " ") + ("flac" "audio/flac" "Free Lossless Audio Codec") + ("flc" "video/flc " "FLIC Animated Picture Autodesk ") + ("fli" "video/fli " "FLIC Animated Picture Autodesk ") + ("fm" "application/vnd.framemaker " "FrameMaker Document") + ("fm3" "application/x-maker " "FrameMaker") + ("fm4" "application/vnd.framemaker" "FrameMaker") + ("fm5" "application/vnd.framemaker" "FrameMaker") + ("fml" "application/fml" " ") + ("fp5" "application/filemaker5" "FileMaker Pro") + ("frl" "application/freeloader" "FormFlow file") + ("frm" "application/vnd.framemaker" "FrameMaker") + ("fs" "application/X-FSRecipe" " ") + ("g3f" "image/g3fax" "Group III FAX") + ("gb" "application/chinese-gb" "Chinese Text") + ("gif" "image/gif" + "GIF - Graphics Interchange Format - Compuserve (raster)") + ("gsd" "audio/x-gsm" "GSM Internet Realtime Audio ") + ("gsm" "audio/x-gsm" "Raw GSM 6.10 Audio Stream ") + ("gtar" "application/x-gtar" "Gnu Tar") + ("gz" "application/x-gzip" "Unix Gzip (gnu-compress ecnapsulation)") + ("hdf" "application/x-hdf" "NCSA HDF (Hierarchical Data Format)") + ("hdml" "text/x-hdml" " ") + ("hlb" "vms/help" "VMS help libraries") + ("hlp" "application/x-mshelp" "Windows Help") + ("hpgl" "application/vnd.hp-HPGL" "HP Graphic Language") + ("hqx" "application/mac-binhex40" + "BinHex 4.0 Format - Macintosh Binary to ASCII conversion.") + ("htm" "text/html" "HTML - HyperText Markup Language") + ("html" "text/html" "HTML - HyperText Markup Language") + ("hz" "application/chinese-hz" "Chinese") + ("ica" "application/x-ica" + "Bitmap graphics (Image Object Content Architecture)") + ("ice" "x-conference/x-cooltalk" " ") + ("ico" "image/ico" "Windows icon") + ("icq" "application/x-icq" "Saved ") + ("ics" "text/calendar" "iCalendar Calendar Data (Mac)") + ("ief" "image/ief" "Image Exchange Format") + ("iff" "image/iff " "Amiga Bitmap Graphic ") + ("iges" "model/iges" " ") + ("img" "image/img" + "Venture Publisher, GEM Draw (bit mapped), AutoCAD CAD-Camera, others") + ("inc" "text/plain" " ") + ("inf" "application/x-setupscript" + "Setup scripts (For Installing Drivers, etc.), Autorun - auto-start file for a CD-ROM") + ("ins" "application/x-NET-Install" "Data (WordPerfect)") + ("ipx" "application/x-ipix" "IPIX AV file") + ("isapi" "wwwserver/isapi" + "Internet Server API - Application Program(ming) Interface") + ("ivr" "i-world/i-vrml" "Virtual Reality World Live Picture ") + ("jar" "application/java-archive" " ") + ("java" "text/plain" " ") + ("jfx" "application/octet-stream" + "eFax Fax Document (J2 Global Communications ") + ("jpe" "image/jpeg" "JPEG-JFIF - Joint Photographic Experts Group") + ("jpeg" "image/jpeg" "JPEG-JFIF - Joint Photographic Experts Group") + ("jpg" "image/jpeg" + "JPEG-JFIF - Joint Photographic Experts Group (raster)") + ("jps" "image/x-jps" "Stereo Image") + ("js" "application/x-javascript" "Java Script") + ("jsc" "application/x-javascript-config" " ") + ("jsp" "magnus-internal/jsp" "Java Script") + ("la" "audio/nspaudio" "Netscape Packetized audio ") + ("latex" "application/x-latex" "LaTeX Source") + ("ldif" "text/x-ldif" + "LDAP Data Interchange Format ( Netscape Address Book)") + ("lha" "application/octet-stream" "LHA Archive") + ("lisp" "text/plain" "Lisp Files") + ("lma" "audio/nspaudio" "Netscape Packetized audio ") + ("loe" "application/vnd.framemaker" "FrameMaker list of exhibits ") + ("lof" "application/vnd.framemaker" "FrameMaker list of figures ") + ("lot" "application/vnd.framemaker" "FrameMaker list of tables ") + ("lwp" "WordPro 9.5 " " ") + ("lzh" "application/octet-stream" "compressed") + ("lzs" "application/octet-stream" "compressed") + ("lzx" "application/octet-stream" "compressed") + ("m13" "application/x-msmediaview" "MS mediaview") + ("m14" "application/x-msmediaview" "MS mediaview") + ("m3u" "audio/x-mpegurl" "Music Playlist (Winamp)") + ("m4a" "audio/" "Apple iTunes AAC and ALE unprotected") + ("ma" "application/mathmetica" "Mathmetica Notebook") + ("m4p" "audio/" "Apple iTunes AAC protected") + ("m4b" "audio/" "Apple iTunes AAC protected autiobook") + ("man" "application/x-troff-man" "Troff w/MAN Macros") + ("map" "application/x-httpd-imap" "Image Configuration File (HTML Image Map)") + ("mbd" "application/mbedlet" " ") + ("mcf" "image/vasa" "Mathcad font") + ("mda" "application/x-msaccess" "MS Access (May not be desirable)") + ("mdb" "application/x-msaccess" "MS access") + ("me" "application/x-troff-me" "Troff w/ME Macros") + ("mesh" "model/mesh" " ") + ("mfp" "application/mirage" " ") + ("mht" "message/rfc822" "Microsoft Web Archiv") + ("mid" "audio/x-midi" "MIDI") + ("midi" "audio/x-midi" "MIDI") + ("mif" "application/vnd.mif" "Maker Interchange Format (FrameMaker)") + ("mime" "message/rfc822" + "base64 (6-bit) is the standard for encoding binary attachme") + ("mk" "application/vnd.framemaker" "FrameMaker") + ("mmf" "application/x-smaf application/vnd.smaf" + "SMAF = \"Synthetic music Mobile Application Format\" - Polyphonic Ringtone File for Phones - Yamaha") + ("mmm" "application/pdf" "Acrobat Media Clip") + ("mny" "application/x-msmoney" "MS money") + ("mocha" "application/x-javascript" "Java Script") + ("mol" "chemical/x-mdl-molfile" "MDL Molfile ") + ("mov" "video/quicktime" "QuickTime digital video") + ("movie" "video/x-sgi-movie" "SGI \"movieplayer\" movie") + ("mp2" "audio/mpeg" "MPEG Audio Stream, Layer II ") + ("mp3" "audio/mpeg" "MPEG Audio Stream, Layer III ") + ("mp4" "video/mp4v-es" + "MPEG Audio Stream, Layer IV (QuickTime and RealPlayer)") + ("mpa" "audio/mpeg" "MPEG Audio Stream, Layer I, II or III ") + ("mpe" "video/mpeg" "MPEG - Motion Picture Experts Group") + ("mpeg" "video/mpeg" "MPEG - Motion Picture Experts Group") + ("mpg" "video/mpeg" "MPEG - Motion Picture Experts Group") + ("mpga" "audio/mpeg" " ") + ("mpire" "application/x-mpire" " ") + ("mpl" "application/x-mpire" " ") + ("mpp" "application/vnd.ms-project" "MS Project") + ("mpt" "application/vnd.ms-project" "MS Project") + ("mpv" "application/vnd.ms-project" "MS Project view") + ("mpw" "application/vnd.ms-project" "MS Project") + ("mpx" "application/vnd.ms-project" "MS Project") + ("ms" "application/x-troff-ms" "Troff w/MS Macros") + ("msh" "model/mesh" "2 and 2-D visualization") + ("n2p" "application/n2p" " ") + ("nc" "application/x-netcdf" "Unidata netCDF data file") + ("npx" "application/x-netfpx" " ") + ("nsc" "application/x-nschat" "Noder file (Polish)") + ("nsf" "application/x-notes" "Lotus Notes ") + ("ntf" "application/x-notes" "Lotus Notes ") + ("ocx" "application/x-oleobject" + "Object Linking and Embedding (OLE) Control Extension (ActiveX Control)") + ("oda" "application/oda" "ODA/ODIF Open Document Architecture ") + ("ods" "application/vnd.oasis.opendocument.spreadsheet" + "Open Office Version 2 spreedsheet") + ("odt" "application/vnd.oasis.opendocument.text;" + "Open Office Version 2 writer") + ("odp" "application/vnd.oasis.opendocument.presentation" + "Open Office Version 2 presentor") + ("ofml" "application/fml" " ") + ("ogg" "audio/x-ogg" "Ogg Vorbis open-source audio format") + ("olb" "vms/olb" "Vax Object Library or MS Project Object Library") + ("or2" "application/x-organizer" "Lotus Organizer") + ("ovl" "application/octet-stream" "PC OVL File") + ("pac" "application/x-ns-proxy-autoconfig" " ") + ("page" "application/x-coda" " ") + ("pbd" "application/vnd.powerbuilder6" "Phone book (FaxNOW! - Faxit)") + ("pbm" "image/x-portable-bitmap" "PBM Bitmap Format") + ("pcd" "image/x-photo-cd" "Kodak Photo CD (raster)") + ("pcl" "application/pcl" " +Printer Control Language (HP)") + ("pcx" "image/pcx" "PC Paintbrush (ZSoft Image)") + ("pdb" "text/x-palm-pdb" "Palm Database File") + ("pdf" "application/pdf" "Portable Document Format (Adobe Acrobat)") + ("pfm" "application/pdf" "Acrobat Font") + ("pfr" "application/font-tdpfr" " ") + ("pgm" "image/x-portable-graymap" "PBM Graymap Format") + ("pgp" "application/pgp-encrypted" "PGP Encrypted file ") + ("pgr" "text/parsnegar-document" " ") + ("php3" "application/x-httpd-php3" " ") + ("phtml" "application/x-httpd-php" "PHP Script ") + ("pic" "image/pict" "Macintosh QuickDraw format (metafile)") + ("pict" "image/pict" "Macintosh QuickDraw format (metafile)") + ("pif" "application/x-mspif" "Program Information File (Windows)") + ("pkr" "application/pgp-keys" "Public Keyring (PGP)") + ("pnc" "text/x-palm-pnc" "Palm Network Configuration File") + ("png" "image/png" "Portable Network Graphics") + ("pnm" "image/x-portable-anymap" "PBM Anymap Format") + ("pot" "application/ms-powerpoint" "MS PowerPoint template") + ("ppa" "application/vnd.ms-powerpoint" "MS PowerPoint addin") + ("ppm" "image/x-portable-pixmap" "PBM Pixmap Format") + ("pps" "application/ms-powerpoint" "MS PowerPoint Slideshow") + ("ppt" "application/ms-powerpoint" "MS PowerPoint Presentation") + ("ppz" "applications/ms-powerpoint" "MS PowerPoint Animation") + ("pqa" "text/x-palm-pqa" "Palm Query Application") + ("pqf" "application/x-cprplayer" " ") + ("pqi" "application/cprplayer" "Power Quest Drive imaging") + ("prc" "text/x-palm-prc" "Palm Application") + ("prvkr" "application/pgp-keys" "Private Keyring (PGP)") + ("ps" "application/postscript" "PostScript") + ("psd" "image/x-photoshop" "Adobe PhotoShop Image") + ("psr" "application/datawindow" "Project Scheduler Resource file") + ("ptlk" "application/listenup" " ") + ("pub" "application/x-mspublisher" "MS publisher or PageMaker 2") + ("pubkr" "application/pgp-keys" "Public Keyring (PGP)") + ("push" "multipart/x-mixed-replace" " ") + ("qd3" "x-world/x-3dmf" "Data file - segment 3 (Omnis Quartz)") + ("qd3d" "x-world/x-3dmf" " ") + ("qrt" "application/quest" "Qrt ray tracing graphics") + ("qt" "video/quicktime" "QuickTime") + ("ra" "audio/x-realaudio" "Music (RealAudio)") + ("ram" "audio/x-pn-realaudio" "Real Audio Player") + ("ras" "image/x-cmu-raster" "Sun Raster Format (raster)") + ("rax" "audio/" "RealAudio 10 - RealMedia Streaming File") + ("rgb" "image/x-rgb" "RGB Color Image") + ("rip" "image/rip" "Graphics (Remote Access)") + ("rm" "audio/x-pn-realaudio" " ") + ("rmf" "audio/x-rmf" "Rich Music Format audio file from Beatnik") + ("rmi" "audio/mid" "MIDI File ") + ("roff" "application/x-troff" "Troff") + ("rpm" "audio/x-pn-realaudio-plugin" + "Real Audio Plugin and RedHat Package Manager") + ("rrf" "application/x-InstallFromTheWeb" " ") + ("rtc" "application/rtc" " ") + ("rtf" "application/rtf" "Rich Text Format (Microsoft)") + ("rtx" "text/richtext" "MIME Richtext format (see also rtf)") + ("rtsp" "application/x-rtsp" + "QuickTime Real-Time Streaming Protocol File ") + ("sb" "application/x-xsb" "Superbook") + ("sbx" "application/x-xsb" + "ArcView Spatial Index For Read-Write Shapefiles ") + ("sca" "application/x-supercard" "Datafile (SCA)") + ("scp" "text/x-palm-scp" "Palm Network Script File") + ("sdp" "application/sdp" "Scalable Multicast (RealNetworks)") + ("ser" "application/java-" " ") + ("sgm" "text/x-sgml" "Standard Generalized Markup Lang (SGML)") + ("sgml" "text/x-sgml" "Standard Generalized Markup Lang (SGML)") + ("sh" "application/x-sh" "SH Script") + ("shar" "application/x-shar" "Sh Shar") + ("shtml" "magnus-internal/parsed-html" " ") + ("shw" "application/presentations" + "Presentation (Harvard Graphics 2.0 - CorelShow)") + ("sig" "application/pgp-signature" "Detached signature file (PGP)") + ("silo" "model/mesh" " ") + ("sit" "application/x-stuffit" + "StuffIt - Macintosh Compression Format. By Aladdin for Mac.") + ("sitx" "application/x-stuffit" + "StuffIt X file format integrates compression with security and safety options. By Aladdin for Mac.") + ("skd" "application/x-koan" " ") + ("skm" "application/x-koan" " ") + ("skp" "application/x-koan" " ") + ("skr" "application/pgp-keys" "Private Keyring (PGP)") + ("skt" "application/x-koan" " ") + ("smil" "application/smil" + "SMIL Synchronized Multimedia Integration Language. App:RealPlayer") + ("sml" "application/smil" + "SMIL Synchronized Multimedia Integration Language") + ("smp" "application/studiom" "Sample (sound file)") + ("snd" "audio/basic" "8-bit u-law [PCM] / 8000 Hz Audio") + ("spc" "text/x-palm-spc" "Palm Configuration File") + ("spl" "application/futuresplash" "FutureSplash from FutureWave Sftwr") + ("spr" "application/x-sprite" "Document letter (Sprint)") + ("sprite" "application/x-sprite" " ") + ("src" "application/x-wais-source" "WAIS Source") + ("stk" "application/hstu" " ") + ("stream" "audio/x-qt-stream" " ") + ("sty" "application/msword" "MS Word Style sheet") + ("sv4cpio" "application/x-sv4cpio" "SVR4 CPIO") + ("sv4crc" "application/x-sv4crc" "SVR4 CPIO w/CRC") + ("svf" "image/vnd" " ") + ("svh" "image/svh" " ") + ("svr" "x-world/x-svr" " ") + ("swf" "application/x-shockwave-flash" + "Macromedia Flash Format File for animations") + ("sxc" "application/vnd.sun.xml.calc" + "Open Office Version 1 Spreedsheet") + ("sxi" "application/vnd.sun.xml.impress" + "Open Office Version 1 Presentations") + ("sxw" " application/vnd.sun.xml.writer" + "Open Office Version 1 Writer") + ("syl" "application/sylk" + "SYLK - Symbolic Link WingZ/Excel/Lotus (old MultiPlan form") + ("sys" "application/octet-stream" "PC System File") + ("talk" "application/talker" "Text to Speech ") + ("tar" "application/x-tar" "4.3BSD Tar ") + ("targa" "image/targa" "Targa Image File") + ("tbk" "application/toolbook" "Memo backup (dBASE IV - FoxPro)") + ("tcl" "application/x-tcl" "TCL Script") + ("tda" "text/x-palm-tda" "ToDo Archive (Palm)") + ("tex" "application/x-tex" "TeX Source") + ("texi" "application/x-texinfo" "Texinfo") + ("texinfo" "application/x-texinfo" "Texinfo") + ("tga" "image/targa" "Targa/Truevision Image File") + ("tgz" "application/x-gzip" "UNIX GTar Arvhive") + ("tif" "image/tiff" "TIFF - Tag Image File Format") + ("tiff" "image/tiff" "TIFF - Tagged Image File Format") + ("tlk" "application/x-tlk" " ") + ("tmv" "application/x-Parable-Thing" "Template (TextMaker)") + ("toc" "application/vnd.framemaker" "FrameMaker TOC") + ("tr" "application/x-troff" "Troff") + ("trm" "application/x-msterminal" "MS terminal") + ("tsi" "audio/tsplayer" " ") + ("tsp" "application/dsptype" "Windows Telephony Service Provider") + ("tsv" "text/tab-separated-values" "Tab Separated Values") + ("txt" "text/plain" "Plain Text") + ("uin" "application/x-icq" "ICQ 2001+ Saved ICQ Contact Information ") + ("url" "application/x-url" + "wwwserver/redirection application/internet-shortcut " + "Uniform resource Locator (Internet Address)") + ("ustar" "application/x-ustar" "IEEE Std1003.2 (``POSIX'') Tar") + ("v5d" "application/vis5d" "5-D data set visualization") + ("vbd" "application/activexdocument" "ActiveX file") + ("vcs" "text/x-vcalendar" + "Personal Data Interchange (PDI) Calendar entry - Outlook") + ("vcd" "application/x-cdlink" "VirtualDrive CD Image File ") + ("vcf" "text/x-vcard" "vCard (Business Card)") + ("vdo" "video/vdo" "VDOLive Script Video image (Story Board)") + ("vgm" "video/x-videogram" " ") + ("vgp" "video/x-videogram-plugin" " ") + ("vgx" "video/x-videogram" " ") + ("viv" "video/vnd.vivo" "VivoActive Player Video file") + ("vivo" "video/vnd.vivo" " ") + ("vmd" "application/vocaltec-media-desc" " ") + ("vmf" "application/vocaltec-media-file" + "Font characteristics (Ventura Publisher)") + ("vob" "video/dvd" "DVD Video Movie File") + ("vox" "audio/voxware" "Vox Audio") + ("vqe" "audio/x-twinvq-plugin" "Yamaha Sound-VQ Locator file") + ("vqf" "audio/x-twinvq" "Yamaha Sound-VQ file") + ("vql" "audio/x-twinvq" "Yamaha Sound-VQ Locator file") + ("vrml" "model/vrml" " ") + ("vrt" "x-world/x-vrt" " ") + ("vts" "workbook/formulaone" + "Forumle One - A Java Spread sheet and report generator from ") + ("waf" "plugin/wanimate" + "Mayim's WAF Compiler file for interactive 3D with Walkabout browser plug-in") + ("wan" "plugin/wanimate" " ") + ("wav" "audio/x-wav" "Windows Audio File WAVE format") + ("wax" "audio/x-ms-wax" "Windows Media Audio Redirector to WMA file.") + ("wbmp" "image/vnd.wap.wbmp" + "Wireless Bitmap File Format - Mobil phones") + ("wi" "image/wavelet" " ") + ("wid" "application/x-DemoShield" "Width table (Ventura Publisher)") + ("wis" "application/x-InstallShield" " ") + ("wks" "application/x-msworks" "MS Works or Lotus 1-2-3 Worksheets") + ("wlt" "application/x-mswallet" "eWallet file") + ("wm" "video/x-ms-wm" " ") + ("wma" "audio/x-ms-wma" "Windows Media Audio. Stored in ASF.") + ("wmf" "image/x-wmf" "Windows MetaFile vector graphics") + ("wml" "text/vnd.wap.wml" "Wireless Markup Language File") + ("wmv" "video/x-ms-wmv" "Windows Media Video (Stored in ASF format)") + ("wp" "application/wordperfect" "WordPerfect") + ("wpc" "application/wpc" + "Text-format converters used 1990-1997 by MS Word and Write") + ("wpc" "application/pcms_wp" "WordPerfect Character Mapping File ") + ("wpd," "application/wordperfect5.1" "Document (WordPerfect)") + ("wps" "application/vnd.ms-works" "MS Works ") + ("wri" "application/x-mswrite" "Write format (MS Windows)") + ("wrl" "model/vrml" "Plain Text VRML File ") + ("wrz" "x-world/x-vrml" " ") + ("wtx" "audio/x-wtx" " ") + ("wvx" "video/x-ms-wvx" " ") + ("xbm" "image/x-xbitmap" "X Bitmaps") + ("xdr" "video/x-videogram" " ") + ("xla" "application/vnd.ms-excel" "MS Excel (Add in)") + ("xlc" "application/vnd.ms-excel" "MS Excel (Chart)") + ("xlm" "application/vnd.ms-excel" "MS Excel") + ("xls" "application/vnd.ms-excel" "MS Excel") + ("xlt" "application/vnd.ms-excel" "MS Excel (template)") + ("xlw" "application/vnd.ms-excel" "MS Excel (workbook)") + ("xml" "text/xml" "Extensible Markup Language") + ("xpm" "image/x-xpixmap" "X Pixmap format") + ("xsb" "application/x-xsb" "Superbook") + ("xwd" "image/x-xwindowdump" "X Window Dump (xwd)") + ("xyz" "chemical/x-pdb" "ASCII RPG Maker Graphic Format") + ("zip" "application/zip" + "Compressed file archive created by PKZIP (pkz204g.exe)") + ("zpa" "application/pcphoto" " "))) + + (defvar *mime-types* (make-hash-table + :test #'equal + :size (length *mime-type-descriptions*))) + + ;;--- Initialize File extension/Mime Type hash table + (dolist (type-lst *mime-type-descriptions*) + (setf (gethash (first type-lst) *mime-types*) (second type-lst)))) + +(defun lookup-mime-type (file-name + &optional (default "application/octet-stream")) + "Extract mime type based on file-extension" + (let ((pos-ext (position #\. file-name :test #'char= :from-end t))) + (when (and pos-ext + (< (1+ pos-ext) (length file-name))) + (or (gethash (subseq file-name (1+ pos-ext)) *mime-types*) + default)))) Added: branches/trunk-reorg/thirdparty/cl-smtp/style.css ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/style.css Tue Jan 29 07:06:27 2008 @@ -0,0 +1,62 @@ + +.header { + font-size: medium; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + text-decoration:underline; } + +th { background-color: #8b0000; + color: white; + text-align: left; } + +.working { background-color: #90ee90; } + +.broken { background-color: #c5c5c5; } \ No newline at end of file Modified: branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp (original) +++ branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp Tue Jan 29 07:06:27 2008 @@ -19,6 +19,7 @@ (lambda (&rest ,arglist) (destructuring-bind ,lambda-list ,arglist + (declare (ignorable ,(car lambda-list))) ,@body))))) (defun get-ps-special-form (name) Added: branches/trunk-reorg/thirdparty/split-sequence/README.cCLan-install ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/split-sequence/README.cCLan-install Tue Jan 29 07:06:27 2008 @@ -0,0 +1,13 @@ +1. Make a symlink in "~/lisp-systems/"[*] pointing to the .asd file +2. Start your asdf-enabled lisp +2a. Ensure that "~/lisp-systems/"[*] is in asdf:*central-registry* +3. At the lisp prompt, type '(asdf:oos 'asdf:load-op "split-sequence")'. This + will compile and load the system into your running lisp. + +[*] This path ("~/lisp-systems/") is only a suggestion; the important +thing is that asdf know where to find the .asd file. Adsf uses the +contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system +definitions. + +These instructions were automatically generated by cCLan software. Use +at your own peril. Added: branches/trunk-reorg/thirdparty/split-sequence/split-sequence.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/split-sequence/split-sequence.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,7 @@ +;;; -*- Lisp -*- mode +(defpackage #:split-sequence-system (:use #:cl #:asdf)) +(in-package :split-sequence-system) + +(defsystem :split-sequence + :version "20011114.1" + :components ((:file "split-sequence"))) Added: branches/trunk-reorg/thirdparty/split-sequence/split-sequence.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/split-sequence/split-sequence.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,243 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication here, which is kept +;;; to illustrate the relationship between the SPLIT-SEQUENCE +;;; functions and the CL:POSITION functions. + +;;; Examples: +;;; +;;; * (split-sequence #\; "a;;b;c") +;;; -> ("a" "" "b" "c"), 6 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t) +;;; -> ("a" "" "b" "c"), 0 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) +;;; -> ("c"), 4 +;;; +;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) +;;; -> ("a" "b" "c"), 6 +;;; +;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 +;;; +;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("ab" "a" "a" "ab" "a"), 11 +;;; +;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) +;;; -> ("oo" "bar" "b"), 9 + +(defpackage "SPLIT-SEQUENCE" + (:use "CL") + (:nicknames "PARTITION") + (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" + "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) + +(in-package "SPLIT-SEQUENCE") + +(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by delimiter. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +(CL:COMPLEMENT predicate). + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if-not predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if-not predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +;;; clean deprecation + +(defun partition (&rest args) + (apply #'split-sequence args)) + +(defun partition-if (&rest args) + (apply #'split-sequence-if args)) + +(defun partition-if-not (&rest args) + (apply #'split-sequence-if-not args)) + +(define-compiler-macro partition (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") + form) + +(define-compiler-macro partition-if (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") + form) + +(define-compiler-macro partition-if-not (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") + form) + +(pushnew :split-sequence *features*) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/LICENSE Tue Jan 29 07:06:27 2008 @@ -0,0 +1,23 @@ +(This is the MIT / X Consortium license as taken from + http://www.opensource.org/licenses/mit-license.html) + +Copyright (c) 2003 Erik Enge + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/Makefile Tue Jan 29 07:06:27 2008 @@ -0,0 +1,9 @@ +# $Id: Makefile 80 2006-02-12 10:09:49Z ehuelsmann $ +# $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/Makefile $ + +clean: + find -name -o -name "*~" -o -name "*.err" -o -name "*.x86f" -o -name "*.lib" -o -name "*.fas" -o -name "*.fasl" -o -name "*.faslmt" -o -name "*.ufsl" -o -name "*.abcl" | xargs rm + +commit: + make clean; svn up; svn ci + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/README Tue Jan 29 07:06:27 2008 @@ -0,0 +1,136 @@ + -*- text -*- + +$Id: README 189 2007-01-20 12:57:27Z ehuelsmann $ + +Content +======= + + * Introduction + * Non-support for :external-format + * API definition + * Known problems + +Introduction +============ +This is the usocket Common Lisp sockets library: a library to bring +sockets access to the broadest of common lisp implementations as possible. + + +The library currently supports: + + - SBCL + - CMUCL + - ArmedBear (post feb 11th, 2006 versions) + - clisp + - Allegro Common Lisp + - LispWorks + - OpenMCL + - ECL + - Scieneer Common Lisp + - <Your favorite Common Lisp here?> + +If your favorite common lisp misses in the list above, please contact +usocket-devel(a)common-lisp.net and submit a request. Please include +references to available sockets functions in your lisp implementation. + +The library has been ASDF (http://cliki.net/ASDF) enabled, meaning +that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL +the package in your system package site. (Or use your usual ASDF +tricks to use the checkout directly.) + + +Non-support of :external-format +=============================== + +Because of its definition in the hyperspec, there's no common +external-format between lisp implementations: every vendor has chosen +a different way to solve the problem of newline translation or +character set recoding. + +Because there's no way to avoid platform specific code in the application +when using external-format, the purpose of a portability layer gets +defeated. So, for now, usocket doesn't support external-format. + +The workaround to get reasonably portable external-format support is to +layer a flexi-stream (from flexi-streams) on top of a usocket stream. + + +API definition +============== + + - usocket (class) + - stream-usocket (class; usocket derivative) + - stream-server-usocket (class; usocket derivative) + - socket-connect (function) [ to create an active/connected socket ] + socket-connect host port &key element-type + where `host' is a vectorized ip + or a string representation of a dotted ip address + or a hostname for lookup in the DNS system + - socket-listen (function) [ to create a passive/listening socket ] + socket-listen host port &key reuseaddress backlog element-type + where `host' has the same definition as above + - socket-accept (method) [ to create an active/connected socket ] + socket-accept socket &key element-type + returns (server side) a connected socket derived from a + listening/passive socket. + - socket-close (method) + socket-close socket + where socket a previously returned socket + - socket (usocket slot accessor), + the internal/implementation defined socket representation + - socket-stream (usocket slot accessor), + socket-stream socket + the return value of which satisfies the normal stream interface + + + + +Errors: + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - connection-aborted-error + - connection-reset-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +Non-fatal conditions: + - interrupted-condition + - unkown-condition + + + + +Known problems +============== +- CMUCL error reporting wrt sockets raises only simple-errors + meaning there's no way to tell different error conditions apart. + All errors are mapped to unknown-error on CMUCL. + +- When running the test suite through the run-usocket-tests.sh shell + script, ArmedBear 0.0.9 will report failure - even when it didn't. + You need a CVS version later than 2006-02-11, or later than 0.0.9 + release version for the script to work correctly. + +- The ArmedBear backend doesn't do any error mapping (yet). Java + defines exceptions at the wrong level (IMO), since the exception + reported bares a relation to the function failing, not the actual + error that occurred: for example 'Address already in use' (when + creating a passive socket) is reported as a BindException with + an error text of 'Address already in use'. There's no way to sanely + map 'BindException' to a meaningfull error in usocket. [This does not + mean the backend should not at least map to 'unknown-error'!] + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/TODO ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/TODO Tue Jan 29 07:06:27 2008 @@ -0,0 +1,8 @@ + +- Extend ABCL socket support with the 4 java errors in java.net.* + so that they can map to our usocket errors instead of mapping + all errors to unknown-error. + +- Add INET6 support. + +For more TODO items, see http://trac.common-lisp.net/usocket/report. Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/allegro.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/allegro.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,125 @@ +;;;; $Id: allegro.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/allegro.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + ;; note: the line below requires ACL 6.2+ + (require :osi)) + +(defun get-host-name () + ;; note: the line below requires ACL 7.0+ to actually *work* on windows + (excl.osi:gethostname)) + +(defparameter +allegro-identifier-error-map+ + '((:address-in-use . address-in-use-error) + (:address-not-available . address-not-available-error) + (:network-down . network-down-error) + (:network-reset . network-reset-error) + (:network-unreachable . network-unreachable-error) + (:connection-aborted . connection-aborted-error) + (:connection-reset . connection-reset-error) + (:no-buffer-space . no-buffers-error) + (:shutdown . shutdown-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-down . host-down-error) + (:host-unreachable . host-unreachable-error))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (excl:socket-error + (let ((usock-err + (cdr (assoc (excl:stream-error-identifier condition) + +allegro-identifier-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error + :real-error condition + :socket socket)))))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (element-type 'character)) + (let ((socket)) + (setf socket + (with-mapped-conditions (socket) + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :format (to-format element-type)))) + (make-stream-socket :socket socket :stream socket))) + + +;; One socket close method is sufficient, +;; because socket-streams are also sockets. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; Allegro and OpenMCL socket interfaces bear very strong resemblence + ;; whatever you change here, change it also for OpenMCL + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions () + (apply #'socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type) + ;; allegro now ignores :format + ) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; allegro streams are multivalent + (let ((stream-sock (with-mapped-conditions () + (socket:accept-connection (socket socket))))) + (make-stream-socket :socket stream-sock :stream stream-sock))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + + +(defun get-host-by-address (address) + (with-mapped-conditions () + (socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + ;;###FIXME: ACL has the acldns module which returns all A records + ;; only problem: it doesn't fall back to tcp (from udp) if the returned + ;; structure is too long. + (with-mapped-conditions () + (list (hbo-to-vector-quad (socket:lookup-hostname + (host-to-hostname name)))))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/armedbear.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/armedbear.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,107 @@ +;;;; $Id: armedbear.lisp 295 2007-09-17 19:53:12Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/armedbear.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + + +(defmacro jmethod-call (instance (method &rest arg-spec) &rest args) + (let ((isym (gensym))) + `(let* ((,isym ,instance) + (class-name (java:jclass-name (java:jclass-of ,isym)))) + (java:jcall (java:jmethod class-name ,method ,@arg-spec) + ,isym ,@args)))) + +(defmacro jnew-call ((class &rest arg-spec) &rest args) + `(java:jnew (java:jconstructor ,class ,@arg-spec) + ,@args)) + +(defun get-host-name () + (let ((localAddress (java:jstatic + (java:jmethod "java.net.InetAddress" + "getLocalHost") + (java:jclass "java.net.InetAddress")))) + (java:jcall (java:jmethod "java.net.InetAddress" "getHostName") + localAddress))) + +(defun handle-condition (condition &optional socket) + (typecase condition + (error (error 'unknown-error :socket socket :real-error condition)))) + +(defun socket-connect (host port &key (element-type 'character)) + (let ((usock)) + (with-mapped-conditions (usock) + (let ((sock (ext:make-socket (host-to-hostname host) port))) + (setf usock + (make-stream-socket + :socket sock + :stream (ext:get-socket-stream sock + :element-type element-type))))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock-addr (jnew-call ("java.net.InetSocketAddress" + "java.lang.String" "int") + (host-to-hostname host) port)) + (sock (jnew-call ("java.net.ServerSocket")))) + (when reuseaddress + (with-mapped-conditions () + (jmethod-call sock + ("setReuseAddress" "boolean") + (java:make-immediate-object reuseaddress :boolean)))) + (with-mapped-conditions () + (jmethod-call sock + ("bind" "java.net.SocketAddress" "int") + sock-addr backlog)) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let* ((jsock (socket socket)) + (jacc-sock (with-mapped-conditions (socket) + (jmethod-call jsock ("accept")))) + (jacc-stream + (ext:get-socket-stream jacc-sock + :element-type (or element-type + (element-type socket))))) + (make-stream-socket :socket jacc-sock + :stream jacc-stream))) + +;;(defun print-java-exception (e) +;; (let* ((native-exception (java-exception-cause e))) +;; (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception)))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (ext:socket-close (socket usocket)))) + +;; Socket streams are different objects than +;; socket streams. Closing the stream flushes +;; its buffers *and* closes the socket. +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-address ((usocket usocket)) + (dotted-quad-to-vector-quad (ext:socket-local-address (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (dotted-quad-to-vector-quad (ext:socket-peer-address (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (ext:socket-local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (ext:socket-peer-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/clisp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/clisp.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,130 @@ +;;;; $Id: clisp.lisp 296 2007-09-17 20:14:43Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/clisp.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + + +;; utility routine for looking up the current host name +(FFI:DEF-CALL-OUT get-host-name-internal + (:name "gethostname") + (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) + :OUT :ALLOCA) + (len ffi:int)) + #+win32 (:library "WS2_32") + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal 256) + (when (= retcode 0) + name))) + + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +clisp-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (system::simple-os-error + (let ((usock-err + (cdr (assoc (car (simple-condition-format-arguments condition)) + +clisp-error-map+ :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition)))))) + +(defun socket-connect (host port &key (element-type 'character)) + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket) + (setf socket + (socket:socket-connect port hostname + :element-type element-type + :buffered t))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to + ;; to explicitly turn it on; unfortunately, there's no way to turn it off... + (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) + (let ((sock (with-mapped-conditions () + (apply #'socket:socket-server + (append (list port + :backlog backlog) + (when (ip/= host *wildcard-host*) + (list :interface host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let ((stream + (with-mapped-conditions (socket) + (socket:socket-accept (socket socket) + :element-type (or element-type + (element-type socket)))))) + (make-stream-socket :socket stream + :stream stream))) + +;; Only one close method required: +;; sockets and their associated streams +;; are the same object +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod socket-close ((usocket stream-server-usocket)) + (socket:socket-server-close (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-local (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-peer (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/cmucl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/cmucl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,167 @@ +;;;; $Id: cmucl.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/cmucl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+win32 +(defun remap-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +cmucl-error-map+ + #+win32 + (append (remap-for-win32 +unix-errno-condition-map+) + (remap-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun cmucl-map-socket-error (err &key condition socket) + (let ((usock-err + (cdr (assoc err +cmucl-error-map+ :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition)))) + +;; CMUCL error handling is brain-dead: it doesn't preserve any +;; information other than the OS error string from which the +;; error can be determined. The OS error string isn't good enough +;; given that it may have been localized (l10n). +;; +;; The above applies to versions pre 19b; 19d and newer are expected to +;; contain even better error reporting. +;; +;; +;; Just catch the errors and encapsulate them in an unknown-error +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)) + (simple-error (error 'unknown-error + :real-condition condition + :socket socket)) + (condition (error condition)))) + +(defun socket-connect (host port &key (element-type 'character)) + (let* ((socket)) + (setf socket + (with-mapped-conditions (socket) + (ext:connect-to-inet-socket (host-to-hbo host) port :stream))) + (if socket + (let* ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full)) + ;;###FIXME the above line probably needs an :external-format + (usocket (make-stream-socket :socket socket + :stream stream))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (server-sock + (with-mapped-conditions () + (apply #'ext:create-inet-listener + (append (list port :stream + :backlog backlog + :reuse-address reuseaddress) + (when (ip/= host *wildcard-host*) + (list :host + (host-to-hbo host)))))))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and socket streams are represented +;; by different objects. Be sure to close the +;; socket stream when closing a stream socket. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (ext:get-socket-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (ext:get-peer-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun lookup-host-entry (host) + (multiple-value-bind + (entry errno) + (ext:lookup-host-entry host) + (if entry + entry + ;;###The constants below work on *most* OSes, but are defined as the + ;; constants mentioned in C + (let ((exception + (second (assoc errno + '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND + (2 ns-no-recovery-error) ;; NO_DATA + (3 ns-no-recovery-error) ;; NO_RECOVERY + (4 ns-try-again)))))) ;; TRY_AGAIN + (when exception + (error exception)))))) + + +(defun get-host-by-address (address) + (handler-case (ext:host-entry-name + (lookup-host-entry (host-byte-order address))) + (condition (condition) (handle-condition condition)))) + +(defun get-hosts-by-name (name) + (handler-case (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list + (lookup-host-entry name))) + (condition (condition) (handle-condition condition)))) + +(defun get-host-name () + (unix:unix-gethostname)) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/lispworks.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/lispworks.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,137 @@ +;;;; $Id: lispworks.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/lispworks.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+win32 +(fli:register-module "ws2_32") + +(fli:define-foreign-function (get-host-name-internal "gethostname" :source) + ((return-string (:reference-return (:ef-mb-string :limit 257))) + (namelen :int)) + :lambda-list (&aux (namelen 256) return-string) + :result-type :int + #+win32 :module #+win32 "ws2_32") + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal) + (when (= 0 retcode) + name))) + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +lispworks-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + + + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (simple-error (destructuring-bind (&optional host port err-msg errno) + (simple-condition-format-arguments condition) + (declare (ignore host port err-msg)) + (let* ((usock-err + (cdr (assoc errno +lispworks-error-map+ + :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition))))))) + +(defun socket-connect (host port &key (element-type 'base-char)) + (let ((hostname (host-to-hostname host)) + (stream)) + (setf stream + (with-mapped-conditions () + (comm:open-tcp-stream hostname port + :element-type element-type))) + (if stream + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) + (error 'unknown-error)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'base-char)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (comm::*use_so_reuseaddr* reuseaddress) + (hostname (host-to-hostname host)) + (sock (with-mapped-conditions () + #-lispworks4.1 (comm::create-tcp-socket-for-service + port :address hostname :backlog backlog) + #+lispworks4.1 (comm::create-tcp-socket-for-service port)))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (let* ((sock (with-mapped-conditions (usocket) + (comm::get-fd-from-socket (socket usocket)))) + (stream (make-instance 'comm:socket-stream + :socket sock + :direction :io + :element-type (or element-type + (element-type usocket))))) + (make-stream-socket :socket sock :stream stream))) + +;; Sockets and their streams are different objects +;; close the stream in order to make sure buffers +;; are correctly flushed and the socket closed. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (close (socket-stream usocket))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (comm::close-socket (socket usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-peer-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (mapcar #'hbo-to-vector-quad + (comm:get-host-entry name :fields '(:addresses))))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,146 @@ +;;;; $Id: openmcl.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/openmcl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defun get-host-name () + (ccl::%stack-block ((resultbuf 256)) + (when (zerop (#_gethostname resultbuf 256)) + (ccl::%get-cstring resultbuf)))) + +(defparameter +openmcl-error-map+ + '((:address-in-use . address-in-use-error) + (:connection-aborted . connection-aborted-error) + (:no-buffer-space . no-buffers-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-unreachable . host-unreachable-error) + (:host-down . host-down-error) + (:network-down . network-down-error) + (:address-not-available . address-not-available-error) + (:network-reset . network-reset-error) + (:connection-reset . connection-reset-error) + (:shutdown . shutdown-error) + (:access-denied . operation-not-permitted-error))) + + +;; we need something which the openmcl implementors 'forgot' to do: +;; wait for more than one socket-or-fd + +(defun input-available-p (sockets &optional ticks-to-wait) + (ccl::rletZ ((tv :timeval)) + (ccl::ticks-to-timeval ticks-to-wait tv) + (ccl::%stack-block ((infds ccl::*fd-set-size*) + (errfds ccl::*fd-set-size*)) + (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))) + (let* ((res (ccl::syscall syscalls::select + (1+ (apply #'max fds)) + 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))) + sockets)))))) + +(defun wait-for-input (sockets &optional ticks-to-wait) + (let ((wait-end (when ticks-to-wait (+ ticks-to-wait (ccl::get-tick-count))))) + (do ((res (input-available-p sockets ticks-to-wait) + (input-available-p sockets ticks-to-wait))) + ((or res (< wait-end (ccl::get-tick-count))) + res)))) + +(defun raise-error-from-id (condition-id socket real-condition) + (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error :socket socket :real-error real-condition)))) + +(defun handle-condition (condition &optional socket) + (typecase condition + (openmcl-socket:socket-error + (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) + socket condition)) + (error (error 'unknown-error :socket socket :real-error condition)) + (condition (signal 'unknown-condition :real-condition condition)))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (element-type 'character)) + (with-mapped-conditions () + (let ((mcl-sock + (openmcl-socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :format (to-format element-type)))) + (openmcl-socket:socket-connect mcl-sock) + (make-stream-socket :stream mcl-sock :socket mcl-sock)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions () + (apply #'openmcl-socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type)) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; openmcl streams are bi/multivalent + (let ((sock (with-mapped-conditions (usocket) + (openmcl-socket:accept-connection (socket usocket))))) + (make-stream-socket :socket sock :stream sock))) + +;; One close method is sufficient because sockets +;; and their associated objects are represented +;; by the same object. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (openmcl-socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (openmcl-socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (openmcl-socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (openmcl-socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defun get-host-by-address (address) + (with-mapped-conditions () + (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname + (host-to-hostname name)))))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/sbcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/sbcl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,194 @@ +;;;; $Id: sbcl.lisp 297 2007-09-17 20:25:40Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/sbcl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; There's no way to preload the sockets library other than by requiring it +;; +;; ECL sockets has been forked off sb-bsd-sockets and implements the +;; same interface. We use the same file for now. +#+ecl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sockets)) + +#+sbcl +(progn + #-win32 + (defun get-host-name () + (sb-unix:unix-gethostname)) + + ;; we assume winsock has already been loaded, after all, + ;; we already loaded sb-bsd-sockets and sb-alien + #+win32 + (defun get-host-name () + (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256))) + (let ((result (sb-alien:alien-funcall + (sb-alien:extern-alien "gethostname" + (sb-alien:function sb-alien:int + (* sb-alien:char) + sb-alien:int)) + (sb-alien:cast buf (* sb-alien:char)) + 256))) + (when (= result 0) + (sb-alien:cast buf sb-alien:c-string)))))) + + +#+ecl +(progn + (ffi:clines + #-:wsock + "#include <sys/socket.h>" + #+:wsock + "#include <winsock2.h>" + + "#include <string.h>" + ) + + (defun get-host-name () + (ffi:c-inline + () () :object + "{ char *buf = GC_malloc(257); + + if (gethostname(buf,256) == 0) + @(return) = make_simple_base_string(strndup(&buf,255)); + else + @(return) = Cnil; + }" :one-liner nil :side-effects nil))) + +(defun map-socket-error (sock-err) + (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) + +(defparameter +sbcl-condition-map+ + '((interrupted-error . interrupted-condition))) + +(defparameter +sbcl-error-map+ + `((sb-bsd-sockets:address-in-use-error . address-in-use-error) + (sb-bsd-sockets::no-address-error . address-not-available-error) + (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error) + (sb-bsd-sockets:connection-refused-error . connection-refused-error) + (sb-bsd-sockets:invalid-argument-error . invalid-argument-error) + (sb-bsd-sockets:no-buffers-error . no-buffers-error) + (sb-bsd-sockets:operation-not-supported-error + . operation-not-supported-error) + (sb-bsd-sockets:operation-not-permitted-error + . operation-not-permitted-error) + (sb-bsd-sockets:protocol-not-supported-error + . protocol-not-supported-error) + (sb-bsd-sockets:socket-type-not-supported-error + . socket-type-not-supported-error) + (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) + (sb-bsd-sockets:operation-timeout-error . timeout-error) + (sb-bsd-sockets:socket-error . ,#'map-socket-error) + ;; Nameservice errors: mapped to unknown-error +;; (sb-bsd-sockets:no-recovery-error . network-reset-error) +;; (sb-bsd-sockets:try-again-condition ...) +;; (sb-bsd-sockets:host-not-found ...) + )) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (error (let* ((usock-error (cdr (assoc (type-of condition) + +sbcl-error-map+))) + (usock-error (if (functionp usock-error) + (funcall usock-error condition) + usock-error))) + (if usock-error + (error usock-error :socket socket) + (error 'unknown-error + :socket socket + :real-error condition)))) + (condition (let* ((usock-cond (cdr (assoc (type-of condition) + +sbcl-condition-map+))) + (usock-cond (if (functionp usock-cond) + (funcall usock-cond condition) + usock-cond))) + (if usock-cond + (signal usock-cond :socket socket) + (signal 'unknown-condition + :real-condition condition)))))) + + +(defun socket-connect (host port &key (element-type 'character)) + (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp)) + (stream (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :buffering :full + :element-type element-type)) + ;;###FIXME: The above line probably needs an :external-format + (usocket (make-stream-socket :stream stream :socket socket)) + (ip (host-to-vector-quad host))) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port)) + usocket)) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (ip (host-to-vector-quad host)) + (sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (with-mapped-conditions () + (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress) + (sb-bsd-sockets:socket-bind sock ip port) + (sb-bsd-sockets:socket-listen sock backlog) + (make-stream-server-socket sock :element-type element-type)))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (with-mapped-conditions (socket) + (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) + (make-stream-socket + :socket sock + :stream (sb-bsd-sockets:socket-make-stream + sock + :input t :output t :buffering :full + :element-type (or element-type + (element-type socket))))))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the stream (which +;; closes the socket too) when closing a stream-socket. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-close (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (sb-bsd-sockets:socket-name (socket usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (sb-bsd-sockets:socket-peername (socket usocket))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (with-mapped-conditions () + (sb-bsd-sockets::host-ent-name + (sb-bsd-sockets:get-host-by-address address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (sb-bsd-sockets::host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/scl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/scl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,137 @@ +;;;; $Id: scl.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/scl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter +scl-error-map+ + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun scl-map-socket-error (err &key condition socket) + (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member)))) + (cond (usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket))) + (t + (error 'unknown-error + :socket socket + :real-error condition))))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (etypecase condition + (ext::socket-error + (scl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)) + (error + (error 'unknown-error + :real-condition condition + :socket socket)))) + +(defun socket-connect (host port &key (element-type 'character)) + (let* ((socket (with-mapped-conditions () + (ext:connect-to-inet-socket (host-to-hbo host) port + :kind :stream))) + (stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full))) + (make-stream-socket :socket socket :stream stream))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (host (if (ip= host *wildcard-host*) + 0 + (host-to-hbo host))) + (server-sock + (with-mapped-conditions () + (ext:create-inet-listener port :stream + :host host + :reuse-address reuseaddress + :backlog backlog)))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the socket stream +;; when closing stream-sockets; it makes sure buffers +;; are flushed and the socket is closed correctly afterwards. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-socket-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-peer-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (multiple-value-bind (host errno) + (ext:lookup-host-entry (host-byte-order address)) + (cond (host + (ext:host-entry-name host)) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip address)) + (t + (error 'ns-unknown-error :host-or-ip address + :real-error errno)))))))) + +(defun get-hosts-by-name (name) + (multiple-value-bind (host errno) + (ext:lookup-host-entry name) + (cond (host + (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list host))) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip name)) + (t + (error 'ns-unknown-error :host-or-ip name + :real-error errno)))))))) + +(defun get-host-name () + (unix:unix-gethostname)) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/condition.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/condition.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,169 @@ +;;;; $Id: condition.lisp 200 2007-02-25 23:09:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/condition.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; Condition raised by operations with unsupported arguments +;; For trivial-sockets compatibility. + +(define-condition unsupported (error) + ((feature :initarg :feature :reader unsupported-feature))) + + +;; Conditions raised by sockets operations + +(define-condition socket-condition (condition) + ((socket :initarg :socket + :accessor usocket-socket)) + ;;###FIXME: no slots (yet); should at least be the affected usocket... + (:documentation "Parent condition for all socket related conditions.")) + +(define-condition socket-error (socket-condition error) + () ;; no slots (yet) + (:documentation "Parent error for all socket related errors")) + +(define-condition ns-condition (condition) + ((host-or-ip :initarg :host-or-ip + :accessor host-or-ip)) + (:documentation "Parent condition for all name resolution conditions.")) + +(define-condition ns-error (ns-condition error) + () + (:documentation "Parent error for all name resolution errors.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun define-usocket-condition-class (class &rest parents) + `(progn + (define-condition ,class ,parents ()) + (export ',class)))) + +(defmacro define-usocket-condition-classes (class-list parents) + `(progn ,@(mapcar #'(lambda (x) + (apply #'define-usocket-condition-class + x parents)) + class-list))) + +;; Mass define and export our conditions +(define-usocket-condition-classes + (interrupted-condition) + (socket-condition)) + +(define-condition unknown-condition (socket-condition) + ((real-condition :initarg :real-condition + :accessor usocket-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + + +;; Mass define and export our errors +(define-usocket-condition-classes + (address-in-use-error + address-not-available-error + bad-file-descriptor-error + connection-refused-error + connection-aborted-error + connection-reset-error + invalid-argument-error + no-buffers-error + operation-not-supported-error + operation-not-permitted-error + protocol-not-supported-error + socket-type-not-supported-error + network-unreachable-error + network-down-error + network-reset-error + host-down-error + host-unreachable-error + shutdown-error + timeout-error + invalid-socket-error + invalid-socket-stream-error) + (socket-error)) + +(define-condition unknown-error (socket-error) + ((real-error :initarg :real-error + :accessor usocket-real-error)) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + + +(define-usocket-condition-classes + (ns-try-again) + (ns-condition)) + +(define-condition ns-unknown-condition (ns-condition) + ((real-error :initarg :real-condition + :accessor ns-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + +(define-usocket-condition-classes + ;; the no-data error code in the Unix 98 api + ;; isn't really an error: there's just no data to return. + ;; with lisp, we just return NIL (indicating no data) instead of + ;; raising an exception... + (ns-host-not-found-error + ns-no-recovery-error) + (ns-error)) + +(define-condition ns-unknown-error (ns-error) + ((real-error :initarg :real-error + :accessor ns-real-error)) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + +(defmacro with-mapped-conditions ((&optional socket) &body body) + `(handler-case + (progn ,@body) + (condition (condition) (handle-condition condition ,socket)))) + +(defparameter +unix-errno-condition-map+ + `(((11) . retry-condition) ;; EAGAIN + ((35) . retry-condition) ;; EDEADLCK + ((4) . interrupted-condition))) ;; EINTR + +(defparameter +unix-errno-error-map+ + ;;### the first column is for non-(linux or srv4) systems + ;; the second for linux + ;; the third for srv4 + ;;###FIXME: How do I determine on which Unix we're running + ;; (at least in clisp and sbcl; I know about cmucl...) + ;; The table below works under the assumption we'll *only* see + ;; socket associated errors... + `(((48 98) . address-in-use-error) + ((49 99) . address-not-available-error) + ((9) . bad-file-descriptor-error) + ((61 111) . connection-refused-error) + ((64 131) . connection-reset-error) + ((130) . connection-aborted-error) + ((22) . invalid-argument-error) + ((55 105) . no-buffers-error) + ((12) . out-of-memory-error) + ((45 95) . operation-not-supported-error) + ((1) . operation-not-permitted-error) + ((43 92) . protocol-not-supported-error) + ((44 93) . socket-type-not-supported-error) + ((51 101) . network-unreachable-error) + ((50 100) . network-down-error) + ((52 102) . network-reset-error) + ((58 108) . already-shutdown-error) + ((60 110) . connection-timeout-error) + ((64 112) . host-down-error) + ((65 113) . host-unreachable-error))) + + +(defun map-errno-condition (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + + +(defun map-errno-error (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + + +(defparameter +unix-ns-error-map+ + `((1 . ns-host-not-found-error) + (2 . ns-try-again-condition) + (3 . ns-no-recovery-error))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/backends.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/backends.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,59 @@ + -*- text -*- + +$Id: backends.txt 182 2007-01-19 23:43:12Z ehuelsmann $ + +A document to describe which APIs a backend should implement. + + +Each backend should implement: + +Functions: + + - handle-condition + - socket-connect + - socket-listen + - get-hosts-by-name [ optional ] + - get-host-by-address [ optional ] + + +Methods: + + - socket-close + - socket-accept + - get-local-name + - get-peer-name + + and - for ip sockets - these methods: + + - get-local-address + - get-local-port + - get-peer-address + - get-peer-port + + +An error-handling function, resolving implementation specific errors +to this list of errors: + + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +and these conditions: + + - interrupted-condition + - unkown-condition Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/design.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/design.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,136 @@ + + -*- text -*- + +$Id: design.txt 122 2006-10-22 08:42:00Z ehuelsmann $ + + + usocket: Universal sockets library + ================================== + +Contents +======== + + * Motivation + * Design goal + * Functional requirements + * Class structure + + + +Motivation +========== + +There are 2 other portability sockets packages [that I know of] +out there: + + 1) trivial-sockets + 2) acl-compat (which is a *lot* broader, but contains sockets too) + +The first misses some functionality which is fundamental when +the requirements stop being 'trivial', such as finding out the +addresses of either side connected to the tcp/ip stream. + +The second, being a complete compatibility library for Allegro, +contains much more than only sockets. Next to that, as the docs +say, is it mainly directed at providing the functionality required +to port portable-allegroserve - meaning it may be (very) incomplete +on some platforms. + +So, that's why I decided to inherit Erik Enge's project to build +a library with the intention to provide portability code in only +1 area of programming, targeted at 'not so trivial' programming. + +Also, I need this library to extend cl-irc with full DCC functionality. + + + +Design goal +=========== + +To provide a portable TCP/IP socket interface for as many +implementations as possible, while keeping the portability layer +as thin as possible. + + + +Functional requirements +======================= + +The interface provided should allow: + - 'client'/active sockets + - 'server'/listening sockets + - provide the usual stream methods to operate on the connection stream + (not necessarily the socket itself; maybe a socket slot too) + +For now, as long as there are no possibilities to have UDP sockets +to write a DNS client library: (which in the end may work better, +because in this respect all implementations are different...) + - retrieve IP addresses/ports for both sides of the connection + +Several relevant support functionalities will have to be provided too: + - long <-> quad-vector operators + - quad-vector <-> string operators + - hostname <-> quad-vector operators (hostname resolution) + + +Minimally, I'd like to support: + - SBCL + - CMUCL + - ABCL (ArmedBear) + - clisp + - Allegro + - LispWorks + - OpenMCL + + +Comments on the design above +============================ + +I don't think it's a good idea to implement name lookup in the +very first of steps: we'll see if this is required to get the +package accepted; not all implementations support it. + +Name resolution errors ... +Since there is no name resolution library (yet), nor standardized +hooks into the standard C library to do it the same way on +all platforms, name resolution errors can manifest themselves +in a lot of different ways. How to marshall these to the +library users? + +Several solutions come to mind: + +1) Map them to 'unknown-error +2) Give them their own errors and map to those + ... which implies that they are actually supported atm. +3) ... + +Given that the library doesn't now, but may in the future, +include name resolution officially, I tend to think (1) is the +right answer: it leaves it all undecided. + +These errors can be raised by the nameresolution service +(netdb.h) as values for 'int h_errno': + +- HOST_NOT_FOUND (1) +- TRY_AGAIN (2) /* Server fail or non-authoritive Host not found */ +- NO_RECOVERY (3) /* Failed permanently */ +- NO_DATA (4) /* Valid address, no data for requested record */ + +int *__h_errno_location(void) points to thread local h_errno on +threaded glibc2 systems. + + +Class structure +=============== + + usocket + | + +- datagram-usocket + +- stream-usocket + \- stream-server-usocket + +The usocket class will have methods to query local properties, such +as: + + - get-local-name: to query to which interface the socket is bound + - <other socket and protocol options such as SO_REUSEADDRESS> Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/abcl-socket.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/abcl-socket.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,18 @@ + +ABCL provides a callback interface to java objects, next to these calls: + + - ext:make-socket + - ext:socket-close + - ext:make-server-socket + - ext:socket-accept + - ext:get-socket-stream (returning an io-stream) + +abcl-swank (see SLIME) shows how to call directly into java. + + +See for the sockets implementation: + + - src/org/armedbear/lisp + * socket.lisp + * socket_stream.java + * SocketStream.java Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/active-sockets-apis.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/active-sockets-apis.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,75 @@ + -*- text -*- + +A document to summarizing which API's of the different implementations +are associated with 'Step 1'. + +Interface to be implemented in step 1: + + - socket-connect + - socket-close + - get-host-by-address + - get-hosts-by-name + +(and something to do with errors; maybe move this to step 1a?) + +SBCL +==== + + sockets: + - socket-bind + - make-instance 'inet-socket + - socket-make-stream + - socket-connect (ip vector-quad) port + - socket-close + + DNS name resolution: + - get-host-by-name + - get-host-by-address + - ::host-ent-addresses + - host-ent-name + + +CMUCL +===== + + sockets: + - ext:connect-to-inet-socket (ip integer) port + - sys:make-fd-stream + - ext:close-socket + + DNS name resolution: + - ext:host-entry-name + - ext::lookup-host-entry + - ext:host-entry-addr-list + - ext:lookup-host-entry + + +ABCL +==== + + sockets + - ext:socket-connect (hostname string) port + - ext:get-socket-stream + - ext:socket-close + + +clisp +===== + + sockets + - socket-connect port (hostname string) + - close (socket) + + +Allegro +======= + + sockets + - make-socket + - socket-connect + - close + + DNS resolution + - lookup-hostname + - ipaddr-to-hostname + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/address-apis.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/address-apis.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,73 @@ + + -*- text -*- + +Step 2 of the master plan: Implementing (get-local-address sock) and +(get-peer-address sock). + + +Step 2 is about implementing: + + (get-local-address sock) -> ip + (get-peer-address sock) -> ip + (get-local-port sock) -> port + (get-peer-port sock) -> port + (get-local-name sock) -> ip, port + (get-peer-name sock) -> ip, port + + +ABCL +==== + + FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local) + FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer) + + (see SLIME / swank-abcl.lisp for an example on how to do that) + + +Allegro +======= + + (values (socket:remote-host sock) + (socket:remote-port)) -> 32bit ip, port + + (values (socket:local-host sock) + (socket:local-port sock)) -> 32bit ip, port + +CLISP +===== + + (socket:socket-stream-local sock nil) -> address (as dotted quad), port + (socket:socket-stream-peer sock nil) -> address (as dotted quad), port + + +CMUCL +===== + + (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer) + (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local) + + +LispWorks +========= + + (comm:socket-stream-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-address sock) -> 32-bit-addr, port + + (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port + + +OpenMCL +======= + + (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port + (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port + + +SBCL +==== + + (sb-bsd-sockets:socket-name sock) -> vector-quad, port + (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port + + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/allegro-socket.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/allegro-socket.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,46 @@ + + +(require :sock) + +accept-connection (sock passive-socket) &key wait Generic function. +dotted-to-ipaddr dotted &key errorp Function. +ipaddr-to-dotted ipaddr &key values Function. +ipaddr-to-hostname ipaddr Function. +lookup-hostname hostname +lookup-port portname protocol Function. +make-socket &key type format address-family connect &allow-other-keys Function. +with-pending-connect &body body Macro. +receive-from (sock datagram-socket) size &key buffer extract Generic function. +send-to sock &key +shutdown sock &key direction +socket-control stream &key output-chunking output-chunking-eof input-chunking +socket-os-fd sock Generic function. + +remote-host socket Generic function. +local-host socket Generic function. +local-port socket + +remote-filename socket +local-filename socket +remote-port socket +socket-address-family socket +socket-connect socket +socket-format socket +socket-type socket + +errors + +:address-in-use Local socket address already in use +:address-not-available Local socket address not available +:network-down Network is down +:network-reset Network has been reset +:connection-aborted Connection aborted +:connection-reset Connection reset by peer +:no-buffer-space No buffer space +:shutdown Connection shut down +:connection-timed-out Connection timed out +:connection-refused Connection refused +:host-down Host is down +:host-unreachable Host is unreachable +:unknown Unknown error + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/clisp-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/clisp-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,38 @@ +http://clisp.cons.org/impnotes.html#socket + +(SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket]) +(SOCKET:SOCKET-SERVER-HOST socket-server) +(SOCKET:SOCKET-SERVER-PORT socket-server) +(SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-STREAM-HOST socket-stream) +(SOCKET:SOCKET-STREAM-PORT socket-stream) +(SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp")) +(SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction) +(SOCKET:SOCKET-OPTIONS socket-server &REST {option}*) + + +(posix:resolve-host-ipaddr &optional host) + +with the host-ent structure: + + name - host name + aliases - LIST of aliases + addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6) + addrtype - INTEGER address type IPv4 or IPv6 + + +Errors are of type + +SYSTEM::SIMPLE-OS-ERROR + with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list + +This integer stores the OS error reported; meaning WSA* codes on Win32 +and E* codes on *nix, only: unix.lisp in CMUCL shows +BSD, Linux and SRV4 have different number assignments for the same +E* constant names :-( + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/cmucl-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/cmucl-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,69 @@ +http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html + +$Id: cmucl-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +extensions:lookup-host-entry host + +[structure] +host-entry + + name aliases addr-type addr-list + +[Function] +extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface + => socket fd + +[Function] +extensions:accept-tcp-connection unconnected + => socket fd, address + +[Function] +extensions:connect-to-inet-socket host port &optional kind + => socket fd + +[Function] +extensions:close-socket socket + + + +[Private function] +extensions::get-peer-host-and-port socket-fd + +[Private function] +extentsions::get-socket-host-and-port socket-fd + + + +There's currently only 1 condition to be raised: + + SOCKET-ERROR (derived from SIMPLE-ERROR) + which has a SOCKET-ERRNO slot containing the unix error number. + + + + +[Function] +extensions:add-oob-handler fd char handler + +[Function] +extensions:remove-oob-handler fd char + +[Function] +extensions:remove-all-oob-handlers fd + +[Function] +extensions:send-character-out-of-band fd char + +[Function] +extensions:create-inet-socket &optional type + => socket fd + +[Function] +extensions:get-socket-option socket level optname + +[Function] +extensions:set-socket-option socket level optname optval + +[Function] +extensions:ip-string addr + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/errors.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/errors.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,20 @@ +EADDRINUSE 48 address-in-use-error +EADDRNOTAVAIL 49 address-not-available-error +EAGAIN interrupted-error ;; not 1 error code: bsd == 11; non-bsd == 35 +EBADF 9 bad-file-descriptor-error +ECONNREFUSED 61 connection-refused-error +EINTR 4 interrupted-error +EINVAL 22 invalid-argument-error +ENOBUFS 55 no-buffers-error +ENOMEM 12 out-of-memory-error +EOPNOTSUPP 45 operation-not-supported-error +EPERM 1 operation-not-permitted-error +EPROTONOSUPPORT 43 protocol-not-supported-error +ESOCKTNOSUPPORT 44 socket-type-not-supported-error +ENETUNREACH 51 network-unreachable-error +ENETDOWN 50 network-down-error +ENETRESET 52 network-reset-error +ESHUTDOWN 58 already-shutdown-error +ETIMEDOUT 60 connection-timeout-error +EHOSTDOWN 64 host-down-error +EHOSTUNREACH 65 host-unreachable-error Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/lw-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/lw-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,41 @@ + +$Id: lw-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM + +Package: COMM + +ip-address-string +socket-stream-address +socket-stream-peer-address +start-up-server +start-up-server-and-mp +string-ip-address +with-noticed-socket-stream + +Needed components for usocket: + +comm::get-fd-from-socket socket-fd + => socket-fd + +comm::accept-connection-to-socket socket-fd + => socket-fd + +comm::close-socket +comm::create-tcp-socket-for-service + => socket-fd + +open-tcp-stream peer-host peer-port &key direction element-type + => socket-stream + +get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-8…) +get-socket-address + +get-socket-peer-address + => address, port + +socket-stream socket-fd + => stream + +socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm) + => socket-fd Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/openmcl-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/openmcl-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,27 @@ +http://openmcl.clozure.com/Doc/sockets.html + + make-socket [Function] + accept-connection [Function] + dotted-to-ipaddr [Function] + ipaddr-to-dotted [Function] + ipaddr-to-hostname [Function] + lookup-hostname [Function] + lookup-port [Function] + receive-from [Function] + send-to [Function] + shutdown [Function] + socket-os-fd [Function] + remote-port [Function] + local-host [Function] + local-port [Function] + + socket-address-family [Function] + + socket-connect [Function] + socket-format [Function] + socket-type [Function] + socket-error [Class] + socket-error-code [Function] + socket-error-identifier [Function] + socket-error-situation [Function] + close [method] Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/sb-bsd-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/sb-bsd-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,114 @@ +http://www.xach.com/sbcl/sb-bsd-sockets.html + +$Id: sb-bsd-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +package: sb-bsd-sockets + +class: socket + +slots: + + * file-descriptor : + * family : + * protocol : + * type : + * stream : + +operators: + + (socket-bind (s socket) &rest address) Generic Function + (socket-accept (socket socket)) Method + (socket-connect (s socket) &rest address) Generic Function + (socket-peername (socket socket)) Method + (socket-name (socket socket)) Method + (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character)) Method + (socket-listen (socket socket) backlog) Method + (socket-close (socket socket)) Method + (socket-make-stream (socket socket) &rest args) Method + + (sockopt-reuse-address (socket socket) argument) Accessor + (sockopt-keep-alive (socket socket) argument) Accessor + (sockopt-oob-inline (socket socket) argument) Accessor + (sockopt-bsd-compatible (socket socket) argument) Accessor + (sockopt-pass-credentials (socket socket) argument) Accessor + (sockopt-debug (socket socket) argument) Accessor + (sockopt-dont-route (socket socket) argument) Accessor + (sockopt-broadcast (socket socket) argument) Accessor + (sockopt-tcp-nodelay (socket socket) argument) Accessor + +inet-domain sockets + +class: inet-socket + +slots: + + * family : + +operators: + + (make-inet-address dotted-quads) Function + (get-protocol-by-name name) Function + (make-inet-socket type protocol) Function + +file-domain sockets + +class: unix-socket + +slots: + + * family : + +class: host-ent + +Slots: + + * name : + * aliases : + * address-type : + * addresses : + + (host-ent-address (host-ent host-ent)) Method + (get-host-by-name host-name) Function + (get-host-by-address address) Function + (name-service-error where) Function + (non-blocking-mode (socket socket)) Method + +(define-socket-condition sockint::EADDRINUSE address-in-use-error) +(define-socket-condition sockint::EAGAIN interrupted-error) +(define-socket-condition sockint::EBADF bad-file-descriptor-error) +(define-socket-condition sockint::ECONNREFUSED connection-refused-error) +(define-socket-condition sockint::EINTR interrupted-error) +(define-socket-condition sockint::EINVAL invalid-argument-error) +(define-socket-condition sockint::ENOBUFS no-buffers-error) +(define-socket-condition sockint::ENOMEM out-of-memory-error) +(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error) +(define-socket-condition sockint::EPERM operation-not-permitted-error) +(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error) +(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error) +(define-socket-condition sockint::ENETUNREACH network-unreachable-error) + +Exported errors: +* (apropos "ERROR" :sb-bsd-sockets) + +SB-BSD-SOCKETS:INTERRUPTED-ERROR +SB-BSD-SOCKETS:TRY-AGAIN-ERROR +* SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?) +SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR +SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR +* SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR +SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:NO-BUFFERS-ERROR +SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR +SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR +SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR +SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR + +And 1 non-exported error: + +SB-BSD-SOCKETS::NO-ADDRESS-ERROR + +*-ed errors aren't yet addressed in the errorlist supported by usocket Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/usock-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/usock-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,28 @@ +Package: + + clisp : socket + cmucl : extensions + sbcl : sb-bsd-sockets + lw : comm + openmcl: openmcl-socket + allegro: sock + +Connecting (TCP/inet only) + + clisp : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream + cmucl : connect-to-inet-socket host port &optional kind => file descriptor + sbcl : sb-socket-connect socket &rest address => socket + lw : open-tcp-stream hostname service &key direction element-type buffered => stream-object + openmcl: socket-connect socket => :active, :passive or nil + allegro: make-socket (&rest args &key type format connect address-family eol) => socket + +Closing + + clisp : close socket + cmucl : close-socket socket + sbcl : socket-close socket + lw : close socket + openmcl: close socket + allegro: close socket + +Errors \ No newline at end of file Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/package.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,47 @@ +;;;; $Id: package.lisp 203 2007-02-28 19:29:04Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/package.lisp $ + +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +#+lispworks (require "comm") + +(eval-when (:execute :load-toplevel :compile-toplevel) + (defpackage :usocket + (:use :cl) + (:export #:socket-connect ; socket constructors and methods + #:socket-listen + #:socket-accept + #:socket-close + #:get-local-address + #:get-peer-address + #:get-local-port + #:get-peer-port + #:get-local-name + #:get-peer-name + + #:with-connected-socket ; convenience macros + #:with-server-socket + #:with-client-socket + #:with-socket-listener + + #:usocket ; socket object and accessors + #:stream-usocket + #:stream-server-usocket + #:socket + #:socket-stream + + #:host-byte-order ; IP(v4) utility functions + #:hbo-to-dotted-quad + #:hbo-to-vector-quad + #:vector-quad-to-dotted-quad + #:dotted-quad-to-vector-quad + #:ip= + #:ip/= + + #:socket-condition ; conditions + #:socket-error ; errors + #:unknown-condition + #:unknown-error))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/run-usocket-tests.sh ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/run-usocket-tests.sh Tue Jan 29 07:06:27 2008 @@ -0,0 +1,57 @@ +#!/bin/sh + +# Test script to be run from the usocket source root +# +# Unfortunately, it currently works only with SBCL +# in my setup... +# +# I need to figure out how to setup ASDF with the other lisps +# I have installed: cmucl, ABCL, clisp, allegro and lispworks + +cd `dirname $0`/test +rm tests.log + +if test -z "$1" ; then + lisps=*.conf +else + lisps=$1 +fi + +for my_lisp_conf in $lisps ; do + + +args= +lisp_bin= +lisp_name= +lisp_exit="(quit result)" + +. $my_lisp_conf + +if test -z "$lisp_bin" ; then + echo "YOU NEED TO SET A LISP BINARY IN YOUR CONF FILE" + exit 1 +fi + +if test -z "$lisp_name" ; then + lisp_name="`basename \"$lisp_bin\"`" +fi + +echo " +#-sbcl (load \"asdf.lisp\") + +(asdf:operate #-sbcl 'asdf:load-source-op + #+sbcl 'asdf:load-op :usocket-test) + +(let ((result (if (usocket-test:do-tests) 1 0))) + $lisp_exit) +" | $lisp_bin $args + +if test $? -eq 1 ; then + echo "PASS: $lisp_name" >> tests.log +else + echo "FAIL: $lisp_name" >> tests.log +fi + +echo "Above the test results gathered for $lisp_name." + +done Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/abcl.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/abcl.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=~/src/abcl-0.0.9/abcl +lisp_name=ArmedBear + +# lisp_exit is required! +lisp_exit="(quit :status result)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/allegro.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/allegro.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args="-batch" + +# lisp_bin is required! +lisp_bin="~/src/acl/acl70_trial/alisp" +lisp_name=Allegro + +# lisp_exit is required! +lisp_exit="(exit result :no-unwind t)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/clisp.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/clisp.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=clisp +lisp_name=clisp + +# lisp_exit is required! +lisp_exit="(quit result)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/cmucl.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/cmucl.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin="~/src/bin/lisp" +lisp_name=CMUCL + +# lisp_exit is required! +lisp_exit="(unix:unix-exit result)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/package.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,13 @@ +;;;; $Id: package.lisp 57 2006-02-07 19:39:46Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/test/package.lisp $ + +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +(eval-when (:execute :load-toplevel :compile-toplevel) + (defpackage :usocket-test + (:use :cl :regression-test) + (:nicknames :usoct) + (:export :do-tests :run-usocket-tests))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/sbcl.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/sbcl.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=sbcl +lisp_name=SBCL + +# lisp_exit is required! +lisp_exit="(quit status :recklessly-p t)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/test-usocket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/test-usocket.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,159 @@ +;;;; $Id: test-usocket.lisp 173 2007-01-18 21:24:25Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/test/test-usocket.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket-test) + +(defmacro with-caught-conditions ((expect throw) &body body) + `(catch 'caught-error + (handler-case + (progn ,@body) + (usocket:unknown-error (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-error c)) + c))) + (error (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c))) + (usocket:unknown-condition (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-condition c)) + c))) + (condition (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c)))))) + +(defparameter +non-existing-host+ "192.168.1.1") +(defparameter +unused-local-port+ 15213) +(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket + :stream :my-stream)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +common-lisp-net+ #(80 68 86 115))) ;; common-lisp.net IP + +(deftest make-socket.1 (usocket:socket *soc1*) :my-socket) +(deftest make-socket.2 (usocket:socket-stream *soc1*) :my-stream) + +(deftest socket-no-connect.1 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect "127.0.0.0" +unused-local-port+) + t) + nil) +(deftest socket-no-connect.2 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect #(127 0 0 0) +unused-local-port+) + t) + nil) +(deftest socket-no-connect.3 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + t) + nil) + +(deftest socket-failure.1 + (with-caught-conditions (#-(or cmu lispworks armedbear openmcl) + 'usocket:network-unreachable-error + #+(or cmu lispworks armedbear) + 'usocket:unknown-error + #+openmcl + 'usocket:timeout-error + nil) + (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + :unreach) + nil) +(deftest socket-failure.2 + (with-caught-conditions (#+(or lispworks armedbear) + 'usocket:unknown-error + #+cmu + 'usocket:network-unreachable-error + #+openmcl + 'usocket:timeout-error + #-(or lispworks armedbear cmu openmcl) + 'usocket:host-unreachable-error + nil) + (usocket:socket-connect +non-existing-host+ 80) ;; 80 = just a port + :unreach) + nil) + + +;; let's hope c-l.net doesn't move soon, or that people start to +;; test usocket like crazy.. +(deftest socket-connect.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) +(deftest socket-connect.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) +(deftest socket-connect.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) + +;; let's hope c-l.net doesn't change its software any time soon +(deftest socket-stream.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (progn + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~A~A~A~A" + #\Return #\Newline #\Return #\Newline) + (force-output (usocket:socket-stream sock)) + (read-line (usocket:socket-stream sock))) + (usocket:socket-close sock)))) + #+clisp "HTTP/1.1 200 OK" + #-clisp #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + +(deftest socket-name.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-address sock) + (usocket:socket-close sock)))) + #.+common-lisp-net+) +(deftest socket-name.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-port sock) + (usocket:socket-close sock)))) + 80) +(deftest socket-name.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-name sock) + (usocket:socket-close sock)))) + #.+common-lisp-net+ 80) +(deftest socket-name.4 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-local-address sock) + (usocket:socket-close sock)))) + #(192 168 1 65)) + + +(defun run-usocket-tests () + (do-tests)) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket-test.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket-test.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,22 @@ +;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/test/usocket-test.asd $ + +;;;; See the LICENSE file for licensing information. + +(in-package #:cl-user) + +(defpackage #:usocket-test-system + (:use #:cl #:asdf)) + +(in-package #:usocket-test-system) + +(defsystem usocket-test + :name "usocket-test" + :author "Erik Enge" + :version "0.1.0" + :licence "MIT" + :description "Tests for usocket" + :depends-on (:usocket :rt) + :components ((:file "package") + (:file "test-usocket" + :depends-on ("package")))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1 @@ +link ../usocket.asd \ No newline at end of file Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/your-lisp.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/your-lisp.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=<path-to-your-lisp-binary-here> +lisp_name= + +# lisp_exit is required! +lisp_exit= Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,43 @@ + +;;;; $Id: usocket.asd 298 2007-09-17 22:08:26Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/usocket.asd $ + +;;;; See the LICENSE file for licensing information. + +(in-package #:cl-user) + +(defpackage #:usocket-system + (:use #:cl #:asdf)) + +(in-package #:usocket-system) + +(defsystem usocket + :name "usocket" + :author "Erik Enge & Erik Huelsmann" + :version "0.3.5" + :licence "MIT" + :description "Universal socket library for Common Lisp" + :depends-on (:split-sequence + #+sbcl :sb-bsd-sockets) + :components ((:file "package") + (:file "usocket" + :depends-on ("package")) + (:file "condition" + :depends-on ("usocket")) + #+clisp (:file "clisp" :pathname "backend/clisp" + :depends-on ("condition")) + #+cmu (:file "cmucl" :pathname "backend/cmucl" + :depends-on ("condition")) + #+scl (:file "scl" :pathname "backend/scl" + :depends-on ("condition")) + #+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl" + :depends-on ("condition")) + #+lispworks (:file "lispworks" :pathname "backend/lispworks" + :depends-on ("condition")) + #+openmcl (:file "openmcl" :pathname "backend/openmcl" + :depends-on ("condition")) + #+allegro (:file "allegro" :pathname "backend/allegro" + :depends-on ("condition")) + #+armedbear (:file "armedbear" :pathname "backend/armedbear" + :depends-on ("condition")) + )) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,322 @@ +;;;; $Id: usocket.lisp 260 2007-06-05 15:23:20Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/usocket.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter *wildcard-host* #(0 0 0 0) + "Hostname to pass when all interfaces in the current system are to be bound.") + +(defparameter *auto-port* 0 + "Port number to pass when an auto-assigned port number is wanted.") + +(defclass usocket () + ((socket + :initarg :socket + :accessor socket + :documentation "Implementation specific socket object instance.")) + (:documentation +"The main socket class. + +Sockets should be closed using the `socket-close' method.")) + +(defclass stream-usocket (usocket) + ((stream + :initarg :stream + :accessor socket-stream + :documentation "Stream instance associated with the socket." +;; +;;Iff an external-format was passed to `socket-connect' or `socket-listen' +;;the stream is a flexi-stream. Otherwise the stream is implementation +;;specific." +)) + (:documentation +"Stream socket class. + +Contrary to other sockets, these sockets may be closed either +with the `socket-close' method or by closing the associated stream +(which can be retrieved with the `socket-stream' accessor).")) + +(defclass stream-server-usocket (usocket) + ((element-type + :initarg :element-type + :initform #-lispworks 'character + #+lispworks 'base-char + :reader element-type + :documentation "Default element type for streams created by +`socket-accept'.")) + (:documentation "Socket which listens for stream connections to +be initiated from remote sockets.")) + +;;Not in use yet: +;;(defclass datagram-usocket (usocket) +;; () +;; (:documentation "")) + +(defun make-socket (&key socket) + "Create a usocket socket type from implementation specific socket." + (unless socket + (error 'invalid-socket)) + (make-stream-socket :socket socket)) + +(defun make-stream-socket (&key socket stream) + "Create a usocket socket type from implementation specific socket +and stream objects. + +Sockets returned should be closed using the `socket-close' method or +by closing the stream associated with the socket. +" + (unless socket + (error 'invalid-socket-error)) + (unless stream + (error 'invalid-socket-stream-error)) + (make-instance 'stream-usocket + :socket socket + :stream stream)) + +(defun make-stream-server-socket (socket &key (element-type + #-lispworks 'character + #+lispworks 'base-char)) + "Create a usocket-server socket type from an +implementation-specific socket object. + +The returned value is a subtype of `stream-server-usocket'. +" + (unless socket + (error 'invalid-socket-error)) + (make-instance 'stream-server-usocket + :socket socket + :element-type element-type)) + +(defgeneric socket-close (usocket) + (:documentation "Close a previously opened `usocket'.")) + +(defgeneric get-local-address (socket) + (:documentation "Returns the IP address of the socket.")) + +(defgeneric get-peer-address (socket) + (:documentation + "Returns the IP address of the peer the socket is connected to.")) + +(defgeneric get-local-port (socket) + (:documentation "Returns the IP port of the socket. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-port (socket) + (:documentation "Returns the IP port of the peer the socket to.")) + +(defgeneric get-local-name (socket) + (:documentation "Returns the IP address and port of the socket as values. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-name (socket) + (:documentation + "Returns the IP address and port of the peer +the socket is connected to as values.")) + +(defmacro with-connected-socket ((var socket) &body body) + "Bind `socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(let ((,var ,socket)) + (unwind-protect + (when ,var + ,@body) + (when ,var + (socket-close ,var))))) + +(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args) + &body body) + "Bind the socket resulting from a call to `socket-connect' with +the arguments `socket-connect-args' to `socket-var' and if `stream-var' is +non-nil, bind the associated socket stream to it." + `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) + ,(if (null stream-var) + `(progn ,@body) + `(let ((,stream-var (socket-stream ,socket-var))) + ,@body)))) + +(defmacro with-server-socket ((var server-socket) &body body) + "Bind `server-socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(with-connected-socket (,var ,server-socket) + ,@body)) + +(defmacro with-socket-listener ((socket-var &rest socket-listen-args) + &body body) + "Bind the socket resulting from a call to `socket-listen' with arguments +`socket-listen-args' to `socket-var'." + `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) + ,@body)) + + +;; +;; IP(v4) utility functions +;; + +(defun list-of-strings-to-integers (list) + "Take a list of strings and return a new list of integers (from +parse-integer) on each of the string elements." + (let ((new-list nil)) + (dolist (element (reverse list)) + (push (parse-integer element) new-list)) + new-list)) + +(defun hbo-to-dotted-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (format nil "~A.~A.~A.~A" first second third fourth))) + +(defun hbo-to-vector-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (vector first second third fourth))) + +(defun vector-quad-to-dotted-quad (vector) + (format nil "~A.~A.~A.~A" + (aref vector 0) + (aref vector 1) + (aref vector 2) + (aref vector 3))) + +(defun dotted-quad-to-vector-quad (string) + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (vector (first list) (second list) (third list) (fourth list)))) + +(defgeneric host-byte-order (address)) +(defmethod host-byte-order ((string string)) + "Convert a string, such as 192.168.1.1, to host-byte-order, +such as 3232235777." + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (+ (* (first list) 256 256 256) (* (second list) 256 256) + (* (third list) 256) (fourth list)))) + +(defmethod host-byte-order ((vector vector)) + "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as +3232235777." + (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) + (* (aref vector 2) 256) (aref vector 3))) + +(defmethod host-byte-order ((int integer)) + int) + +(defun host-to-hostname (host) + "Translate a string or vector quad to a stringified hostname." + (etypecase host + (string host) + ((vector t 4) (vector-quad-to-dotted-quad host)) + (integer (hbo-to-dotted-quad host)))) + +(defun ip= (ip1 ip2) + (etypecase ip1 + (string (string= ip1 (host-to-hostname ip2))) + ((vector t 4) (or (eq ip1 ip2) + (and (= (aref ip1 0) (aref ip2 0)) + (= (aref ip1 1) (aref ip2 1)) + (= (aref ip1 2) (aref ip2 2)) + (= (aref ip1 3) (aref ip2 3))))) + (integer (= ip1 (host-byte-order ip2))))) + +(defun ip/= (ip1 ip2) + (not (ip= ip1 ip2))) + +;; +;; DNS helper functions +;; + +#-(or clisp armedbear) +(progn + (defun get-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (car hosts))) + + (defun get-random-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (when hosts + (elt hosts (random (length hosts)))))) + + (defun host-to-vector-quad (host) + "Translate a host specification (vector quad, dotted quad or domain name) +to a vector quad." + (etypecase host + (string (let* ((ip (ignore-errors + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? + ip + (get-random-host-by-name host)))) + ((vector t 4) host) + (integer (hbo-to-vector-quad host)))) + + (defun host-to-hbo (host) + (etypecase host + (string (let ((ip (ignore-errors + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((vector t 4) (host-byte-order host)) + (integer host)))) + +;; +;; Setting of documentation for backend defined functions +;; + +;; Documentation for the function +;; +;; (defun SOCKET-CONNECT (host port) ..) +;; + +(setf (documentation 'socket-connect 'function) + "Connect to `host' on `port'. `host' is assumed to be a string or +an IP address represented in vector notation, such as #(192 168 1 1). +`port' is assumed to be an integer. + +Returns a usocket object.") + +;; Documentation for the function +;; +;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..) +;;###FIXME: extend with default-element-type +(setf (documentation 'socket-listen 'function) + "Bind to interface `host' on `port'. `host' should be the +representation of an interface address. The implementation is not +required to do an address lookup, making no guarantees that hostnames +will be correctly resolved. If `*wildcard-host*' is passed for `host', +the socket will be bound to all available interfaces for the IPv4 +protocol in the system. `port' can be selected by the IP stack by +passing `*auto-port*'. + +Returns an object of type `stream-server-usocket'. + +`reuse-address' and `backlog' are advisory parameters for setting socket +options at creation time. `element-type' is the element type of the +streams to be created by `socket-accept'. `reuseaddress' is supported for +backward compatibility (but deprecated); when both `reuseaddress' and +`reuse-address' have been specified, the latter takes precedence. +") + +;; Documentation for the function +;; +;; (defun SOCKET-ACCEPT (socket &key element-type) +(setf (documentation 'socket-accept 'function) + "Accepts a connection from `socket', returning a `stream-socket'. + +The stream associated with the socket returned has `element-type' when +explicitly specified, or the element-type passed to `socket-listen' otherwise.")

1 0

[bknr-cvs] r2414 - in branches/bos/projects/bos: m2 web
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 06:43:20 2008 New Revision: 2414 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/web/kml-handlers.lisp Log: kml-handler now uses the new function CONTRACT-NEIGHBOURS and exports and entire region (a first version...) Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 06:43:20 2008 @@ -44,10 +44,16 @@ (setf (first ,point) x (second ,point) y) (when ,(if test - `(funcall ,test point) + `(funcall ,test ,point) t) ,@body))))) +(defun rect-center (left top width height &key roundp) + (let ((x (+ left (/ width 2))) + (y (+ top (/ height 2)))) + (if roundp + (list (round x) (round y)) + (list x y)))) ;; maybe change this function to take a ;; point as an argument? Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Tue Jan 29 06:43:20 2008 @@ -350,6 +350,21 @@ (setf max-y (max (m2-y m2) (or max-y (m2-y m2))))) (list min-x min-y (1+ (- max-x min-x)) (1+ (- max-y min-y))))) +(defun contract-neighbours (contract &optional (radius 100)) + (destructuring-bind (left top width height) + (contract-bounding-box contract) + (let ((center (rect-center left top width height :roundp t)) + (diameter (* 2 radius)) + (contracts (make-hash-table :test #'eq))) + (with-points (center) + (dorect (point ((- center-x radius) (- center-y radius) diameter diameter) + :test (lambda (point) (point-in-circle-p point center radius))) + (with-points (point) + (awhen (get-m2 point-x point-y) + (when (m2-contract it) + (setf (gethash (m2-contract it) contracts) t)))))) + (hash-keys contracts)))) + (defun tx-make-contract (sponsor m2-count &key date paidp expires) (warn "Old tx-make-contract transaction used, contract dates may be wrong") (tx-do-make-contract sponsor m2-count :date date :paidp paidp :expires expires)) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Tue Jan 29 06:43:20 2008 @@ -2,7 +2,10 @@ (defpackage :geometry (:use :cl :iterate :arnesi) - (:export #:distance + (:export #:with-points + #:distance + #:dorect + #:rect-center #:point-in-polygon-p #:point-in-circle-p #:find-boundary-point @@ -127,6 +130,7 @@ #:contract-date #:contract-m2s #:contract-bounding-box + #:contract-neighbours #:contract-color #:contract-cert-issued #:contract-set-paidp Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Tue Jan 29 06:43:20 2008 @@ -1,15 +1,5 @@ (in-package :bos.web) -(defun contract-utm-bounding-box (contract) - "Returns LEFT, TOP, RIGHT, BOTTOM." - (let (min-x min-y max-x max-y) - (dolist (m2 (contract-m2s contract)) - (setf min-x (min (m2-utm-x m2) (or min-x (m2-utm-x m2)))) - (setf min-y (min (m2-utm-y m2) (or min-y (m2-utm-y m2)))) - (setf max-x (max (m2-utm-x m2) (or max-x (m2-utm-x m2)))) - (setf max-y (max (m2-utm-y m2) (or max-y (m2-utm-y m2))))) - (list min-x max-y max-x min-y))) - (defun kml-format-points (points) (format nil "~:{~F,~F,0 ~}" points)) @@ -20,28 +10,31 @@ ()) (defmethod handle-object ((handler contract-kml-handler) (contract contract) req) - (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") ;; when name is xmlns, the attribute does not show up - why (?) ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") - (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract)))) - (with-element "Document" - (with-element "Placemark" - (with-element "name" (format nil "contract~a" (store-object-id contract))) - (with-element "description" "a description") - (with-element "Style" - (attribute "id" "#region") - (with-element "LineStyle" - (with-element "color" (text "ffff3500"))) - (with-element "PolyStyle" - (with-element "color" (text (kml-format-color (contract-color contract) 175))))) - (with-element "Polygon" - (with-element "styleUrl" "#region") - (with-element "tessellate" (text "1")) - (with-element "outerBoundaryIs" - (with-element "LinearRing" - (with-element "coordinates" - (text (kml-format-points polygon))))))))))) + (with-element "Document" + (dolist (contract (contract-neighbours contract)) + (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract))) + (name (user-full-name (contract-sponsor contract)))) + (with-element "Placemark" + (with-element "name" (text (format nil "~A ~Dm2" + (if name name "anonymous") + (length (contract-m2s contract))))) + (with-element "description" (text "a description")) + (with-element "Style" + (attribute "id" "#region") + (with-element "LineStyle" + (with-element "color" (text "ffff3500"))) + (with-element "PolyStyle" + (with-element "color" (text (kml-format-color (contract-color contract) 175))))) + (with-element "Polygon" + (with-element "styleUrl" "#region") + (with-element "tessellate" (text "1")) + (with-element "outerBoundaryIs" + (with-element "LinearRing" + (with-element "coordinates" + (text (kml-format-points polygon)))))))))))) (defmethod handle-object ((handle-object contract-kml-handler) (object null) req) (error "Contract not found.")) -

1 0

[bknr-cvs] r2413 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 05:06:55 2008 New Revision: 2413 Modified: branches/bos/projects/bos/m2/geometry.lisp Log: added macro DORECT in geometry.lisp Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 05:06:55 2008 @@ -2,6 +2,7 @@ ;; a point in this package is represented ;; as a list (x y) + (defmacro with-point (point &body body) (let* ((*package* (symbol-package point)) (x (intern (format nil "~A-X" (symbol-name point)))) @@ -21,6 +22,33 @@ (sqrt (+ (expt (- point-a-x point-b-x) 2) (expt (- point-a-y point-b-y) 2))))) +(defmacro dorect ((point (left top width height) &key test row-change) &body body) + "Iterate with POINT over all points in rect row per row. The list +containing x and y is intended for only extracting those +and not to be stored away (it will be modified). + +BODY is only executed, if TEST of the current point is true. + +For convenience, a null arg function ROW-CHANGE can be given +that will be called between the rows." + (check-type point symbol) + (rebinding (left top) + `(iter + (with ,point = (list nil nil)) + (for y from ,top to (1- (+ ,top ,height))) + ,(when row-change + `(unless (first-time-p) + (funcall ,row-change))) + (iter + (for x from ,left to (1- (+ ,left ,width))) + (setf (first ,point) x + (second ,point) y) + (when ,(if test + `(funcall ,test point) + t) + ,@body))))) + + ;; maybe change this function to take a ;; point as an argument? (defun point-in-polygon-p (x y polygon) @@ -42,6 +70,14 @@ (defun point-in-circle-p (point center radius) (<= (distance point center) radius)) +;;; for fun... +(defun point-in-circle-p-test () + (let ((center (list 4 4))) + (dorect (p (0 0 10 10) :row-change #'terpri) + (if (point-in-circle-p p center 3) + (princ "x") + (princ "."))))) + ;;; directions ;; A direction can be represented either

1 0

[bknr-cvs] r2412 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 04:17:50 2008 New Revision: 2412 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/packages.lisp Log: added DISTANCE and POINT-IN-CIRCLE-P to geometry.lisp Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 04:17:50 2008 @@ -1,8 +1,25 @@ - (in-package :geometry) ;; a point in this package is represented ;; as a list (x y) +(defmacro with-point (point &body body) + (let* ((*package* (symbol-package point)) + (x (intern (format nil "~A-X" (symbol-name point)))) + (y (intern (format nil "~A-Y" (symbol-name point))))) + `(destructuring-bind (,x ,y) ,point + ,@body))) + +(defmacro with-points ((&rest points) &body body) + (if (null points) + `(progn ,@body) + `(with-point ,(car points) + (with-points (,@(cdr points)) + ,@body)))) + +(defun distance (point-a point-b) + (with-points (point-a point-b) + (sqrt (+ (expt (- point-a-x point-b-x) 2) + (expt (- point-a-y point-b-y) 2))))) ;; maybe change this function to take a ;; point as an argument? @@ -22,6 +39,9 @@ pjy piy)) result)) +(defun point-in-circle-p (point center radius) + (<= (distance point center) radius)) + ;;; directions ;; A direction can be represented either Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Tue Jan 29 04:17:50 2008 @@ -2,7 +2,9 @@ (defpackage :geometry (:use :cl :iterate :arnesi) - (:export #:point-in-polygon-p + (:export #:distance + #:point-in-polygon-p + #:point-in-circle-p #:find-boundary-point #:region-to-polygon))

1 0

[bknr-cvs] r2411 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 28 Jan '08

28 Jan '08

Author: ksprotte Date: Mon Jan 28 11:09:33 2008 New Revision: 2411 Modified: branches/bos/projects/bos/web/news-handlers.lisp Log: a test commit for #7 Modified: branches/bos/projects/bos/web/news-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/news-handlers.lisp (original) +++ branches/bos/projects/bos/web/news-handlers.lisp Mon Jan 28 11:09:33 2008 @@ -11,22 +11,23 @@ (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) (let ((language (session-variable :language))) - (with-bos-cms-page (req :title "Choose news item to edit") + (with-bos-cms-page (req :title "Edit news items") (content-language-chooser req) - (if (all-news-items) - (html - (:h2 "Choose existing news item") - (:ul - (dolist (news-item (all-news-items)) - (let ((id (store-object-id news-item))) - (html (:li (cmslink #?"edit-news/$(id)" - (:princ-safe (format-date-time (news-item-time news-item))) - " - " - (:princ-safe (or (news-item-title news-item language) "[no title in this language]"))))))))) - (html - (:h2 "No news items created yet"))) + (:h2 "Create new item") ((:form :method "post") - (submit-button "new" "new"))))) + (submit-button "new" "new")) + (if (all-news-items) + (html + (:h2 "Choose existing news item") + (:ul + (dolist (news-item (all-news-items)) + (let ((id (store-object-id news-item))) + (html (:li (cmslink #?"edit-news/$(id)" + (:princ-safe (format-date-time (news-item-time news-item))) + " - " + (:princ-safe (or (news-item-title news-item language) "[no title in this language]"))))))))) + (html + (:h2 "No news items created yet")))))) (defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req) (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req))

1 0

[bknr-cvs] r2410 - in branches/trunk-reorg/thirdparty/slime: . CVS contrib contrib/CVS doc doc/CVS
by hhubner＠common-lisp.net 28 Jan '08

28 Jan '08

Author: hhubner Date: Mon Jan 28 06:47:40 2008 New Revision: 2410 Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries branches/trunk-reorg/thirdparty/slime/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries branches/trunk-reorg/thirdparty/slime/doc/slime.texi branches/trunk-reorg/thirdparty/slime/slime.el branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp branches/trunk-reorg/thirdparty/slime/swank-scl.lisp branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp branches/trunk-reorg/thirdparty/slime/swank.lisp Log: update from recent CVS slime Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries Mon Jan 28 06:47:40 2008 @@ -1,35 +1,35 @@ -/.cvsignore/1.5/Thu Oct 11 14:10:25 2007// -/HACKING/1.8/Thu Oct 11 14:10:25 2007// -/PROBLEMS/1.8/Thu Oct 11 14:10:25 2007// -/README/1.14/Thu Oct 11 14:10:25 2007// -/hyperspec.el/1.11/Thu Oct 11 14:10:25 2007// -/metering.lisp/1.4/Thu Oct 11 14:10:25 2007// -/mkdist.sh/1.7/Thu Oct 11 14:10:25 2007// -/nregex.lisp/1.4/Thu Oct 11 14:10:25 2007// -/sbcl-pprint-patch.lisp/1.1/Thu Oct 11 14:10:25 2007// -/slime-autoloads.el/1.3/Thu Oct 11 14:10:25 2007// -/swank-abcl.lisp/1.44/Wed Nov 14 21:30:35 2007// -/swank-allegro.lisp/1.98/Thu Oct 11 14:10:25 2007// -/swank-backend.lisp/1.126/Thu Oct 11 14:10:25 2007// -/swank-clisp.lisp/1.64/Thu Oct 11 14:10:25 2007// -/swank-corman.lisp/1.11/Thu Oct 11 14:10:25 2007// -/swank-ecl.lisp/1.8/Thu Oct 11 14:10:25 2007// -/swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007// -/swank-openmcl.lisp/1.120/Wed Nov 14 21:30:35 2007// -/swank-sbcl.lisp/1.185/Thu Oct 11 14:10:25 2007// -/swank-scl.lisp/1.13/Thu Oct 11 14:10:25 2007// -/swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007// -/swank-source-path-parser.lisp/1.17/Thu Oct 11 14:10:25 2007// -/swank.asd/1.5/Thu Oct 11 14:10:25 2007// -/test-all.sh/1.2/Thu Oct 11 14:10:25 2007// -/test.sh/1.9/Thu Oct 11 14:10:25 2007// -/xref.lisp/1.2/Thu Oct 11 14:10:25 2007// D/contrib//// D/doc//// -/ChangeLog/1.1254/Sun Dec 2 04:22:09 2007// -/NEWS/1.9/Sun Dec 2 04:22:09 2007// -/slime.el/1.882/Sun Dec 2 04:22:09 2007// -/swank-cmucl.lisp/1.175/Sun Dec 2 04:22:09 2007// -/swank-lispworks.lisp/1.93/Sun Dec 2 04:22:09 2007// -/swank-loader.lisp/1.75/Sun Dec 2 04:22:09 2007// -/swank.lisp/1.521/Sun Dec 2 04:22:09 2007// +/.cvsignore/1.5/Sun Apr 8 19:23:57 2007// +/ChangeLog/1.1274/Sun Jan 27 22:03:20 2008// +/HACKING/1.8/Sun Jan 27 22:03:20 2008// +/NEWS/1.9/Sun Jan 27 22:03:20 2008// +/PROBLEMS/1.8/Sun Jan 27 22:03:20 2008// +/README/1.14/Sun Jan 27 22:03:20 2008// +/hyperspec.el/1.11/Sun Jan 27 22:03:20 2008// +/metering.lisp/1.4/Sun Jan 27 22:03:20 2008// +/mkdist.sh/1.7/Sun Jan 27 22:03:20 2008// +/nregex.lisp/1.4/Sun Jan 27 22:03:20 2008// +/sbcl-pprint-patch.lisp/1.1/Sun Jan 27 22:03:20 2008// +/slime-autoloads.el/1.3/Sun Jan 27 22:03:20 2008// +/slime.el/1.896/Sun Jan 27 22:03:20 2008// +/swank-abcl.lisp/1.44/Sun Jan 27 22:03:20 2008// +/swank-allegro.lisp/1.98/Sun Jan 27 22:03:20 2008// +/swank-backend.lisp/1.126/Sun Jan 27 22:03:21 2008// +/swank-clisp.lisp/1.64/Sun Jan 27 22:03:21 2008// +/swank-cmucl.lisp/1.175/Sun Jan 27 22:03:21 2008// +/swank-corman.lisp/1.11/Sun Jan 27 22:03:21 2008// +/swank-ecl.lisp/1.11/Sun Jan 27 22:03:21 2008// +/swank-gray.lisp/1.10/Sun Jan 27 22:03:21 2008// +/swank-lispworks.lisp/1.93/Sun Jan 27 22:03:21 2008// +/swank-loader.lisp/1.75/Sun Jan 27 22:03:21 2008// +/swank-openmcl.lisp/1.120/Sun Jan 27 22:03:21 2008// +/swank-sbcl.lisp/1.187/Sun Jan 27 22:03:21 2008// +/swank-scl.lisp/1.14/Sun Jan 27 22:03:21 2008// +/swank-source-file-cache.lisp/1.8/Sun Jan 27 22:03:21 2008// +/swank-source-path-parser.lisp/1.18/Sun Jan 27 22:03:21 2008// +/swank.asd/1.5/Sun Jan 27 22:03:21 2008// +/swank.lisp/1.523/Sun Jan 27 22:03:21 2008// +/test-all.sh/1.2/Sun Jan 27 22:03:21 2008// +/test.sh/1.9/Sun Jan 27 22:03:21 2008// +/xref.lisp/1.2/Sun Jan 27 22:03:21 2008// Modified: branches/trunk-reorg/thirdparty/slime/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/ChangeLog Mon Jan 28 06:47:40 2008 @@ -1,3 +1,156 @@ +2008-01-27 Helmut Eller <heller(a)common-lisp.net> + + Make it easier to start a non-default Lisp from ELisp code. + + * slime.el (slime): If the argument is a symbol start the + corresponding entry in slime-lisp-implementations. + Typical use is something like: + (defun cmucl () (interactive) (slime 'cmucl)) + +2008-01-22 Lu�s Oliveira <loliveira(a)common-lisp.net> + + * swank-source-path-parser.lisp (make-source-recording-readtable): + don't suppress the #. reader macro. + (read-and-record-source-map): don't bind *read-eval* to nil. + (suppress-sharp-dot): unused, delete it. + + * slime.el (test compile-defun): test with #+#.'(:and). + +2008-01-21 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-mode): Don't throw to toplevel in the + kill-buffer-hook, since the buffer can be killed for other reasons + too. + (test break): Test BREAK and CONTINUE in a loop. + (slime-wait-condition): Display the current time. + +2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + New hooks that allow the slime-presentations contrib to hook + into the debugger and inspector. + + * slime.el (sldb-insert-frame-variable-value-function): New + variable. + (sldb-insert-frame-variable-value): New function, default value + for sldb-insert-frame-variable-value-function. + (sldb-insert-locals): Use it here. + + * slime.el (slime-inspector-insert-ispec-function): New variable. + (slime-open-inspector): Use it here. + +2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * doc/slime.texi (Presentations): Improve documentation of + presentations. + +2008-01-19 Geo Carncross <geocar(a)gmail.com> + + * swank-ecl.lisp (inspect-for-emacs): Make ECL inspection better; + should be able to handle all builtin types and CLOS objects now. + +2008-01-17 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank-sbcl.lisp (sbcl-source-file-p): When a buffer is not + associated with any file, M-. for names defined there ends up + calling SBCL-SOURCE-FILE-P with NIL -- guard against that. + +2008-01-14 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (sldb-mode): Add `sldb-quit' to `kill-buffer-hook' to + close the debugging machinery on swank side when the SLDB buffer + is killed. (Notice that killing the SLDB buffer manually will not + restore window configuration in contrast to typing `q'.) + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-delete-and-extract-region): New + function. Portable version of `delete-and-extract-region' which + returned NIL instead of "", as experienced by Matthias Koeppe. + +2008-01-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-mode-map): Bind C-c C-t to + slime-toggle-trace-fdefinition (as in Lisp buffers) instead of + slime-repl-clear-buffer. This binding is useful for untracing + functions directly from the trace output. Move + slime-repl-clear-buffer to the keybinding C-c M-o. + +2008-01-04 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (source-file-source-location): Use the + debootstrap readtable when appropriate (fixes occasional reader + errors when using "v" on debugger frames that point to functions + defined in SBCL). Likewise for the debootstrapping packages. + (code-location-debug-source-name): Ensure that we always return a + physical namestring, Emacs won't like a pathname or a logical + namestring. + +2008-01-02 Lu�s Oliveira <loliveira(a)common-lisp.net> + + Use sane default values for slime-repl-set-package. + + Previously, when typing `,!p' at the REPL, the current package + would have been inserted as a default (although the whole intent + was to /change/ the current package in the first place), now + nothing is inserted anymore. + + * slime.el (slime-pretty-current-package): rename it to + slime-pretty-find-buffer-package and make it use + slime-find-buffer-package instead of slime-current-package. + (slime-repl-set-package, slime-set-package): use new function. + +2008-01-02 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-print-apropos): Simplified: Don't insert action + properties anymore for the symbol; they were ignored anyway, + because `apropos-follow' (bound to RET in the resulting + *SLIME Apropos* buffer) looks for buttons only. + +2008-01-02 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-apropos): Update docstring: Apropos doesn't + match on regular expressions anymore since 2007-11-24. + +2007-12-22 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-scl.lisp (set-stream-timeout, make-socket-io-stream): update + for Scieneer CL 1.3.7. + +2007-12-20 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (read-softly-from-string): Now actually returns all + three values as explained in its docstring. + +2007-12-14 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-insert-xref-location): New function. Tries to + either insert the file name a function is defined in, or inserts + information about the buffer a function was interactively + `C-c C-c'd from. Idea from Knut Olav B�hmer. + (slime-insert-xrefs): Use it. + +2007-12-04 Helmut Eller <heller(a)common-lisp.net> + + Simplify the inspector. + + * swank.lisp (inspect-object): Ignore the title value returned + from backends. + + * slime.el (slime-open-inspector): Updated accordingly. + +2007-12-04 Helmut Eller <heller(a)common-lisp.net> + + Fix slime-list-thread selector. + + * slime.el (slime-list-threads): Wait for the result before + continuing. + +2007-12-04 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-insert-result): Use slime-repl-emit-result + since handling of markers has changed. + (slime-repl-emit-result): New argument: bol. + 2007-12-02 Alan Caulkins <fatman(a)maxint.net> Make it possible to close listening sockets. @@ -7,7 +160,7 @@ (setup-server): Store open sockets in *listener-sockets*. 2007-12-02 Helmut Eller <heller(a)common-lisp.net> - + Add hook to customize the region used by C-c C-c. Useful to recognize block declarations in CMUCL sources. Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries Mon Jan 28 06:47:40 2008 @@ -1,30 +1,33 @@ -/README/1.3/Thu Oct 11 14:10:25 2007// -/bridge.el/1.1/Thu Oct 11 14:10:25 2007// -/inferior-slime.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-asdf.el/1.3/Thu Oct 11 14:10:25 2007// -/slime-autodoc.el/1.5/Thu Oct 11 14:10:25 2007// -/slime-banner.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007// -/slime-editing-commands.el/1.5/Thu Oct 11 14:10:25 2007// -/slime-fancy-inspector.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-fancy.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007// -/slime-parse.el/1.7/Thu Oct 11 14:10:25 2007// -/slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-presentations.el/1.8/Thu Oct 11 14:10:25 2007// -/slime-references.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-scratch.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-tramp.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-typeout-frame.el/1.5/Thu Oct 11 14:10:25 2007// -/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007// -/swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007// -/swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007// -/swank-fuzzy.lisp/1.6/Thu Oct 11 14:10:25 2007// -/swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007// -/swank-presentation-streams.lisp/1.4/Thu Oct 11 14:10:25 2007// -/swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007// -/swank-fancy-inspector.lisp/1.5/Wed Nov 21 20:47:43 2007// -/ChangeLog/1.68/Sun Dec 2 04:22:09 2007// -/slime-fuzzy.el/1.5/Sun Dec 2 04:22:09 2007// -/swank-arglists.lisp/1.15/Sun Dec 2 04:22:10 2007// +/ChangeLog/1.82/Sun Jan 27 22:03:21 2008// +/README/1.3/Sun Jan 27 22:03:21 2008// +/bridge.el/1.1/Sun Jan 27 22:03:22 2008// +/inferior-slime.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-asdf.el/1.3/Sun Jan 27 22:03:22 2008// +/slime-autodoc.el/1.7/Sun Jan 27 22:03:22 2008// +/slime-banner.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-c-p-c.el/1.8/Sun Jan 27 22:03:22 2008// +/slime-editing-commands.el/1.6/Sun Jan 27 22:03:22 2008// +/slime-fancy-inspector.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-fancy.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-fuzzy.el/1.6/Sun Jan 27 22:03:22 2008// +/slime-highlight-edits.el/1.3/Sun Jan 27 22:03:22 2008// +/slime-parse.el/1.10/Sun Jan 27 22:03:22 2008// +/slime-presentation-streams.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-presentations.el/1.12/Sun Jan 27 22:03:22 2008// +/slime-references.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-scheme.el/1.1/Wed Jan 9 18:30:26 2008// +/slime-scratch.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-tramp.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-typeout-frame.el/1.6/Sun Jan 27 22:03:22 2008// +/slime-xref-browser.el/1.1/Sun Jan 27 22:03:22 2008// +/swank-arglists.lisp/1.18/Sun Jan 27 22:03:22 2008// +/swank-asdf.lisp/1.1/Sun Jan 27 22:03:22 2008// +/swank-c-p-c.lisp/1.2/Sun Jan 27 22:03:22 2008// +/swank-fancy-inspector.lisp/1.5/Sun Jan 27 22:03:22 2008// +/swank-fuzzy.lisp/1.7/Sun Jan 27 22:03:22 2008// +/swank-goo.goo/1.1/Sat Jan 19 14:08:27 2008// +/swank-kawa.scm/1.1/Sat Jan 19 14:08:27 2008// +/swank-listener-hooks.lisp/1.1/Sun Jan 27 22:03:22 2008// +/swank-presentation-streams.lisp/1.4/Sun Jan 27 22:03:22 2008// +/swank-presentations.lisp/1.4/Sun Jan 27 22:03:22 2008// D Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog Mon Jan 28 06:47:40 2008 @@ -1,3 +1,151 @@ +2008-01-27 Helmut Eller <heller(a)common-lisp.net> + + Make autodoc use the correct width of the typeout-window. + + * slime-autodoc.el (slime-autodoc-dimensions-function): New + variable. + (slime-autodoc-message-dimensions): Use it. + + * slime-typeout-frame.el (slime-typeout-autodoc-dimensions): New + function. + (slime-typeout-frame-init): Use it. + +2008-01-27 Helmut Eller <heller(a)common-lisp.net> + + Use slime-require instead of a connected-hook. + + * slime-autodoc.el (slime-autodoc-on-connect): Deleted. + +2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Hook presentations into debugger and inspector, restoring + features that were removed on 2007-08-27. + + * slime-presentations.el (slime-presentation-add-easy-menu): + Install presentation menu also in the debugger and inspector. + (slime-presentation-inspector-insert-ispec): New. + (slime-presentation-sldb-insert-frame-variable-value): New. + (slime-presentations-init): Install these functions as + slime-inspector-insert-ispec-function and + sldb-insert-frame-variable-value-function. + +2008-01-19 Helmut Eller <heller(a)common-lisp.net> + + * swank-goo.goo: New file. + * swank-kawa.scm: New file. + +2008-01-11 Stelian Ionescu <sionescu(a)common-lisp.net> + + * slime-presentations.el + (slime-copy-or-inspect-presentation-at-mouse): Call + slime-copy-presentation-at-mouse-to-repl rather than + slime-copy-presentation-at-mouse. + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-parse.el (slime-make-form-spec-from-string): Correctly + handle quoted things and other non-proper "(...)" forms. + + * swank-arglist.lisp (read-form-spec): Added assertion against + receiving junk form specs from Emacs. + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-editing-commands.el (slime-close-all-parens-in-sexp): Use + new portability function `slime-delete-and-extract-region'. + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-parse.lisp (slime-incomplete-form-at-point): Hopefully + better fix than before. + +2008-01-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Add keyboard commands (starting with C-c C-v) and a top-level menu + for presentation-related commands. Add a command (C-c C-v M-o) to + forget all objects associated with presentations, without + clearing the REPL buffer. + + * slime-presentations.el + (slime-presentation-around-or-before-point-or-error): New + function. + (slime-inspect-presentation): New function, factored out from + slime-inspect-presentation-at-mouse. + (slime-inspect-presentation-at-mouse): Use it here. + (slime-inspect-presentation-at-point): New command. + (slime-copy-presentation-to-repl): New function, factored out + from slime-copy-presentation-at-mouse. + (slime-copy-presentation-at-mouse-to-repl): Renamed from + slime-copy-presentation-at-mouse; use the new function + slime-copy-presentation-to-repl. + (slime-copy-presentation-at-point-to-repl): New command. + (slime-copy-presentation-to-kill-ring): New function, factored + out from slime-copy-presentation-at-mouse-to-kill-ring. + (slime-copy-presentation-at-point-to-kill-ring): New command. + (slime-describe-presentation): New function, factored out from + slime-describe-presentation-at-mouse. + (slime-describe-presentation-at-mouse): Use it here. + (slime-describe-presentation-at-point): New command. + (slime-pretty-print-presentation): New function, factored out + from slime-pretty-print-presentation-at-mouse. + (slime-pretty-print-presentation-at-mouse): Use it here. + (slime-pretty-print-presentation-at-point): New command. + (slime-mark-presentation): New command. + (slime-previous-presentation, slime-next-presentation): New + commands. + (slime-presentation-command-map, slime-presentation-bindings): + New variables. + (slime-presentation-init-keymaps): New function. + (slime-presentation-around-or-before-point-p): New function. + (slime-presentation-easy-menu): New variable. + (slime-presentation-add-easy-menu): New function. + (slime-clear-presentations): Make interactive, remove + presentation markup from all presentations in the REPL buffer. + (slime-presentations-init): Call slime-presentation-init-keymaps + and slime-presentation-add-easy-menu. + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-parse.lisp (slime-incomplete-form-at-point): Take the + arglist index the user's point is located at correctly into + account. Previously `C-c C-s' on `(defun |foo' would have inserted + `args body...)', now it inserts `name args body...)' + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-arglists.lisp (read-form-spec): Changed "cons" clause to + "list" clause in etypecase. Fix for error on arglist display on + `(declare (ftype (|)))', | being point. + +2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-fuzzy.el (slime-fuzzy-completion-time-limit-in-msec): + Update docstring: Its value isn't rounded to nearest second, but + is really interpreted as msecs. + + * swank-fuzzy.el: Updated some comments. + (fuzzy-generate-matchings): Sort package matchings before + traversal, such that they're traversed in the order of their + score. (Important when time limit exhausts during traversal.) + +2008-01-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Restore support for Scheme programs that was removed from core + SLIME on 2007-09-19, as a "slime-scheme" contrib. + + * slime-scheme.el: New file. + +2007-12-30 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-arglists.lisp: Fix for `(cerror "FOO" 'type-error ...)' + + (*arglist-dummy*): Removed. + (arglist-dummy): New structure. Wrapper around whatever could not + be reliably read. The clue is that its printing function does only + print the object this structure contains. + (read-conversatively-for-autodoc): Return such a structure if + conversative reading fails. + 2007-11-27 Tobias C. Rittweiler <tcr(a)freebits.de> * swank-arglists.lisp (arglist-dispatch 'defmethod): Use Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el Mon Jan 28 06:47:40 2008 @@ -116,10 +116,14 @@ (setq slime-autodoc-last-message doc) (message "%s" doc)) +(defvar slime-autodoc-dimensions-function nil) + (defun slime-autodoc-message-dimensions () "Return the available width and height for pretty printing autodoc messages." (cond + (slime-autodoc-dimensions-function + (funcall slime-autodoc-dimensions-function)) (slime-autodoc-use-multiline-p ;; Use the full width of the minibuffer; ;; minibuffer will grow vertically if necessary @@ -253,21 +257,18 @@ (defun slime-autodoc-init () (setq slime-echo-arglist-function 'slime-autodoc) - (add-hook 'slime-connected-hook 'slime-autodoc-on-connect) (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) (add-hook h 'slime-autodoc-maybe-enable))) -(defun slime-autodoc-on-connect () - (slime-eval-async '(swank:swank-require :swank-arglists))) - (defun slime-autodoc-maybe-enable () (when slime-use-autodoc-mode (slime-autodoc-mode 1))) (defun slime-autodoc-unload () (setq slime-echo-arglist-function 'slime-show-arglist) - (remove-hook 'slime-connected-hook 'slime-autodoc-on-connect) (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) (remove-hook h 'slime-autodoc-maybe-enable))) +(slime-require :swank-arglists) + (provide 'slime-autodoc) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el Mon Jan 28 06:47:40 2008 @@ -69,7 +69,7 @@ (setq point (point)) ;; count sexps until either '(' or comment is found at first column (while (and (not (looking-at "^[(;]")) - (ignore-errors (backward-up-list 1) t)) + (ignore-errors (backward-up-list 1) t)) (incf sexp-level)))) (when (> sexp-level 0) ;; insert correct number of right parens @@ -79,7 +79,7 @@ (setq point (point)) (skip-chars-forward " \t\n)") (skip-chars-backward " \t\n") - (let* ((deleted-region (delete-and-extract-region point (point))) + (let* ((deleted-region (slime-delete-and-extract-region point (point))) (deleted-text (substring-no-properties deleted-region)) (prior-parens-count (count ?\) deleted-text))) ;; Remember: we always insert as many parentheses as necessary Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el Mon Jan 28 06:47:40 2008 @@ -30,8 +30,8 @@ :type 'integer) (defcustom slime-fuzzy-completion-time-limit-in-msec 1500 - "Limit the time spent (given in msec) in swank while gathering comletitions. -\(NOTE: currently it's rounded up the nearest second)" + "Limit the time spent (given in msec) in swank while gathering +comletitions." :group 'slime-mode :type 'integer) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el Mon Jan 28 06:47:40 2008 @@ -16,14 +16,15 @@ (slime-enclosing-form-specs) (if (null operators) "" - (let ((op (first operators))) + (let ((op (first operators)) + (op-start (first points)) + (arg-index (first arg-indices))) (destructure-case (slime-ensure-list op) ((:declaration declspec) op) ((:type-specifier typespec) op) - (t (slime-ensure-list - (save-excursion (goto-char (first points)) - (slime-parse-sexp-at-point - (1+ (first arg-indices))))))))))) + (t + (slime-make-form-spec-from-string + (concat (slime-incomplete-sexp-at-point) ")")))))))) ;; XXX: unused function (defun slime-cl-symbol-external-ref-p (symbol) @@ -228,9 +229,11 @@ => (\"foo\" (\"bar\" \"1\" (\"baz\" \":quux\")) \"'toto\") " - (cond ((slime-length= string 0) "") - ((equal string "()") '()) - (t + (cond ((slime-length= string 0) "") ; "" + ((equal string "()") '()) ; "()" + ((eql (char-syntax (aref string 0)) ?\') string) ; "'(foo)", "#(foo)" &c + ((not (eql (aref string 0) ?$)) string) ; "foo" + (t ; "(op arg1 arg2 ...)" (with-temp-buffer ;; Do NEVER ever try to activate `lisp-mode' here with ;; `slime-use-autodoc-mode' enabled, as this function is used @@ -246,17 +249,18 @@ (delete-region (point-min) (point)) (insert "("))) (goto-char (1- (point-max))) ; `(OP arg1 ... argN|)' + (assert (eql (char-after) ?$)) (multiple-value-bind (forms indices points) (slime-enclosing-form-specs 1) (if (null forms) string (let ((n (first (last indices)))) - (goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)' - (mapcar #'(lambda (s) - (assert (not (equal s string))) ; trap against - (slime-make-form-spec-from-string s)) ; endless recursion. - (slime-ensure-list - (slime-parse-sexp-at-point (1+ n) t)))))))))) + (goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)' + (mapcar #'(lambda (s) + (assert (not (equal s string))) ; trap against + (slime-make-form-spec-from-string s)) ; endless recursion. + (slime-ensure-list + (slime-parse-sexp-at-point (1+ n) t)))))))))) (defun slime-enclosing-form-specs (&optional max-levels) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el Mon Jan 28 06:47:40 2008 @@ -275,6 +275,13 @@ (values presentation start end whole-p) (slime-presentation-around-point (1- point) object))))) +(defun slime-presentation-around-or-before-point-or-error (point) + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-or-before-point point) + (unless presentation + (error "No presentation at point")) + (values presentation start end whole-p))) + (defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer))) "Call `function' with arguments `presentation', `start', `end', `whole-p' for every presentation in the region `from'--`to' in the @@ -345,40 +352,58 @@ (slime-presentation-around-click event) (if (with-current-buffer buffer (eq major-mode 'slime-repl-mode)) - (slime-copy-presentation-at-mouse event) + (slime-copy-presentation-at-mouse-to-repl event) (slime-inspect-presentation-at-mouse event)))) +(defun slime-inspect-presentation (presentation start end buffer) + (let ((reset-p + (with-current-buffer buffer + (not (eq major-mode 'slime-inspector-mode))))) + (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) + 'slime-open-inspector))) + (defun slime-inspect-presentation-at-mouse (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) - (let ((reset-p - (with-current-buffer buffer - (not (eq major-mode 'slime-inspector-mode))))) - (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) - 'slime-open-inspector)))) + (slime-inspect-presentation presentation start end buffer))) + +(defun slime-inspect-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-inspect-presentation presentation start end (current-buffer)))) + +(defun slime-copy-presentation-to-repl (presentation start end buffer) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (unless (eql major-mode 'slime-repl-mode) + (slime-switch-to-output-buffer)) + (flet ((do-insertion () + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) + (save-excursion + (goto-char (point-max)) + (do-insertion)))))) -(defun slime-copy-presentation-at-mouse (event) +(defun slime-copy-presentation-at-mouse-to-repl (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) - (let ((presentation-text - (with-current-buffer buffer - (buffer-substring start end)))) - (unless (eql major-mode 'slime-repl-mode) - (slime-switch-to-output-buffer)) - (flet ((do-insertion () - (when (not (string-match "\\s-" - (buffer-substring (1- (point)) (point)))) - (insert " ")) - (insert presentation-text) - (when (and (not (eolp)) (not (looking-at "\\s-"))) - (insert " ")))) - (if (>= (point) slime-repl-prompt-start-mark) - (do-insertion) - (save-excursion - (goto-char (point-max)) - (do-insertion))))))) + (slime-copy-presentation-to-repl presentation start end buffer))) + +(defun slime-copy-presentation-at-point-to-repl (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-copy-presentation-to-repl presentation start end (current-buffer)))) (defun slime-copy-presentation-at-mouse-to-point (event) (interactive "e") @@ -395,29 +420,94 @@ (when (and (not (eolp)) (not (looking-at "\\s-"))) (insert " "))))) +(defun slime-copy-presentation-to-kill-ring (presentation start end buffer) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (kill-new presentation-text) + (message "Saved presentation \"%s\" to kill ring" presentation-text))) + (defun slime-copy-presentation-at-mouse-to-kill-ring (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) - (let ((presentation-text - (with-current-buffer buffer - (buffer-substring start end)))) - (kill-new presentation-text)))) + (slime-copy-presentation-to-kill-ring presentation start end buffer))) + +(defun slime-copy-presentation-at-point-to-kill-ring (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-copy-presentation-to-kill-ring presentation start end (current-buffer)))) +(defun slime-describe-presentation (presentation) + (slime-eval-describe + `(swank::describe-to-string + (swank::lookup-presented-object ',(slime-presentation-id presentation))))) + (defun slime-describe-presentation-at-mouse (event) (interactive "@e") (multiple-value-bind (presentation) (slime-presentation-around-click event) - (slime-eval-describe - `(swank::describe-to-string - (swank::lookup-presented-object ',(slime-presentation-id presentation)))))) + (slime-describe-presentation presentation))) + +(defun slime-describe-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation) + (slime-presentation-around-or-before-point-or-error point) + (slime-describe-presentation presentation))) + +(defun slime-pretty-print-presentation (presentation) + (slime-eval-describe + `(swank::swank-pprint + (cl:list + (swank::lookup-presented-object ',(slime-presentation-id presentation)))))) (defun slime-pretty-print-presentation-at-mouse (event) (interactive "@e") (multiple-value-bind (presentation) (slime-presentation-around-click event) - (slime-eval-describe - `(swank::swank-pprint - (cl:list - (swank::lookup-presented-object ',(slime-presentation-id presentation))))))) + (slime-pretty-print-presentation presentation))) + +(defun slime-pretty-print-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation) + (slime-presentation-around-or-before-point-or-error point) + (slime-pretty-print-presentation presentation))) + +(defun slime-mark-presentation (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (goto-char start) + (push-mark end nil t))) + +(defun slime-previous-presentation () + "Move point to the beginning of the first presentation before point." + (interactive) + ;; First skip outside the current surrounding presentation (if any) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point (point)) + (when presentation + (goto-char start))) + (let ((p (previous-single-property-change (point) 'slime-repl-presentation))) + (unless p + (error "No previous presentation")) + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error p) + (goto-char start)))) + +(defun slime-next-presentation () + "Move point to the beginning of the next presentation after point." + (interactive) + ;; First skip outside the current surrounding presentation (if any) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point (point)) + (when presentation + (goto-char end))) + (let ((p (next-single-property-change (point) 'slime-repl-presentation))) + (unless p + (error "No next presentation")) + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error p) + (goto-char start)))) (defvar slime-presentation-map (make-sparse-keymap)) @@ -451,7 +541,7 @@ ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse)) ("Describe" . ,(savel 'slime-describe-presentation-at-mouse)) ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse)) - ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse)) + ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl)) ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring)) ,@(unless buffer-read-only `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point)))) @@ -541,6 +631,64 @@ (let ((inhibit-read-only t)) (insert old-output))))) +;;; Presentation-related key bindings, non-context menu + +(defvar slime-presentation-command-map (make-sparse-keymap) + "Keymap for presentation-related commands. Bound to a prefix key.") + +(defvar slime-presentation-bindings + '((?i slime-inspect-presentation-at-point) + (?d slime-describe-presentation-at-point) + (?w slime-copy-presentation-at-point-to-kill-ring) + (?r slime-copy-presentation-at-point-to-repl) + (?p slime-previous-presentation) + (?n slime-next-presentation) + (? slime-mark-presentation))) + +(defun slime-presentation-init-keymaps () + (setq slime-presentation-command-map (make-sparse-keymap)) + (loop for (key command) in slime-presentation-bindings + do (progn + ;; We bind both unmodified and with control. + (define-key slime-presentation-command-map (vector key) command) + (let ((modified (slime-control-modified-char key))) + (define-key slime-presentation-command-map (vector modified) command)))) + (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations) + ;; C-c C-v is the prefix for the presentation-command map. + (slime-define-key "\C-v" slime-presentation-command-map :prefixed t :inferior t) + (define-key slime-repl-mode-map "\C-c\C-v" slime-presentation-command-map) + (define-key sldb-mode-map "\C-c\C-v" slime-presentation-command-map) + (define-key slime-inspector-mode-map "\C-c\C-v" slime-presentation-command-map)) + +(defun slime-presentation-around-or-before-point-p () + (multiple-value-bind (presentation beg end) + (slime-presentation-around-or-before-point (point)) + presentation)) + +(defvar slime-presentation-easy-menu + (let ((P '(slime-presentation-around-or-before-point-p))) + `("Presentations" + [ "Inspect" slime-inspect-presentation-at-point ,P ] + [ "Describe" slime-describe-presentation-at-point ,P ] + [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ] + [ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ] + [ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ] + [ "Mark" slime-mark-presentation ,P ] + "--" + [ "Previous presentation" slime-previous-presentation ] + [ "Next presentation" slime-next-presentation ] + "--" + [ "Clear all presentations" slime-clear-presentations ]))) + +(defun slime-presentation-add-easy-menu () + (easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-add slime-presentation-easy-menu 'slime-mode-map) + (easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map) + (easy-menu-add slime-presentation-easy-menu 'sldb-mode-map) + (easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map)) ;;; hook functions (hard to isolate stuff) @@ -622,7 +770,38 @@ bridge-handlers))) (defun slime-clear-presentations () - (slime-eval-async `(swank:clear-repl-results))) + "Forget all objects associated to SLIME presentations. +This allows the garbage collector to remove these objects +even on Common Lisp implementations without weak hash tables." + (interactive) + (slime-eval-async `(swank:clear-repl-results)) + (unless (eql major-mode 'slime-repl-mode) + (slime-switch-to-output-buffer)) + (slime-for-each-presentation-in-region 1 (1+ (buffer-size)) + (lambda (presentation from to whole-p) + (slime-remove-presentation-properties from to + presentation)))) + +(defun slime-presentation-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (destructure-case ispec + ((:value string id) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (slime-insert-presentation string `(:inspected-part ,id) t))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-presentation-sldb-insert-frame-variable-value (value frame index) + (slime-insert-presentation + (in-sldb-face local-value value) + `(:frame-var ,slime-current-thread ,(car frame) ,i) t)) ;;; Initialization @@ -639,7 +818,12 @@ (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input) (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations) - (add-hook 'slime-connected-hook 'slime-install-presentations)) + (add-hook 'slime-connected-hook 'slime-install-presentations) + (setq slime-inspector-insert-ispec-function 'slime-presentation-inspector-insert-ispec) + (setq sldb-insert-frame-variable-value-function + 'slime-presentation-sldb-insert-frame-variable-value) + (slime-presentation-init-keymaps) + (slime-presentation-add-easy-menu)) (defun slime-install-presentations () (slime-eval-async '(swank:swank-require :swank-presentations))) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el Mon Jan 28 06:47:40 2008 @@ -64,6 +64,12 @@ (setq slime-autodoc-last-message "") (slime-typeout-message-aux "%s" doc)) +(defun slime-typeout-autodoc-dimensions () + (cond ((slime-typeout-active-p) + (list (window-width slime-typeout-window) nil)) + (t + (list 75 nil)))) + ;;; Initialization @@ -74,7 +80,8 @@ (loop for (var value) in '((slime-message-function slime-typeout-message) (slime-background-message-function slime-typeout-message) - (slime-autodoc-message-function slime-typeout-autodoc-message)) + (slime-autodoc-message-function slime-typeout-autodoc-message) + (slime-autodoc-dimensions-function slime-typeout-autodoc-dimensions)) do (slime-typeout-frame-init-var var value))) (defun slime-typeout-frame-init-var (var value) @@ -86,6 +93,7 @@ (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame) (loop for (var value) in slime-typeout-frame-unbind-stack do (cond ((eq var 'slime-unbound) (makunbound var)) - (t (set var value))))) + (t (set var value)))) + (setq slime-typeout-frame-unbind-stack nil)) (provide 'slime-typeout-frame) Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp Mon Jan 28 06:47:40 2008 @@ -72,7 +72,14 @@ (let ((op-rawspec (nth (1+ position) raw-specs))) (first (parse-form-spec op-rawspec #'read-conversatively-for-autodoc)))) -(defvar *arglist-dummy* (cons :dummy nil)) +;; This is a wrapper object around anything that came from Slime and +;; could not reliably be read. +(defstruct (arglist-dummy + (:conc-name #:arglist-dummy.) + (:print-object (lambda (struct stream) + (with-struct (arglist-dummy. string-representation) struct + (write-string string-representation stream))))) + string-representation) (defun read-conversatively-for-autodoc (string) "Tries to find the symbol that's represented by STRING. @@ -83,8 +90,8 @@ automatic arglist display stuff from Slime, interning freshly symbols is a big no-no. -In such a case (that no symbol could be found), the object -*ARGLIST-DUMMY* is returned instead, which works as a placeholder +In such a case (that no symbol could be found), an object of type +ARGLIST-DUMMY is returned instead, which works as a placeholder datum for subsequent logics to rely on." (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) (quoted? (eql (aref string 0) #\'))) @@ -92,7 +99,7 @@ (parse-symbol (if quoted? (subseq string 1) string)) (if found? (if quoted? `(quote ,symbol) symbol) - *arglist-dummy*)))) + (make-arglist-dummy :string-representation string))))) (defun parse-form-spec (raw-spec &optional reader) @@ -215,7 +222,7 @@ (push sexp result) (when newly-interned? (push sexp newly-interned-symbols)))) - (cons + (list (multiple-value-bind (read-spec interned-symbols) (read-form-spec element reader) (push read-spec result) @@ -232,7 +239,8 @@ the flag if a symbol had to be interned." (multiple-value-bind (sexp pos interned?) (read-softly-from-string string) - (declare (ignore pos)) + ;; To make sure that we haven't got any junk from Emacs. + (assert (= pos (length string))) (values sexp interned?))) Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp Mon Jan 28 06:47:40 2008 @@ -220,15 +220,20 @@ ;; relative to all the packages found. (multiple-value-bind (found-packages rest-time-limit) (find-packages parsed-package-name time-limit-in-msec) + ;; We want to traverse the found packages in the order of their score, + ;; since those with higher score presumably represent better choices. + ;; (This is important because some packages may never be looked at if + ;; time limit exhausts during traversal.) + (setf found-packages (sort found-packages #'fuzzy-matching-greaterp)) (loop for package-matching across found-packages for package = (find-package (fuzzy-matching.package-name package-matching)) while (or (not time-limit) (> rest-time-limit 0)) do (multiple-value-bind (matchings remaining-time) - ;; The filter removes all those symbols which are also present - ;; in one of the other packages, specifically if such a package - ;; represents the home package of the symbol, because that one - ;; is deemed to be the best match. + ;; The duplication filter removes all those symbols which are + ;; present in more than one package match. Specifically if such a + ;; package match represents the home package of the symbol, it's + ;; the one kept because this one is deemed to be the best match. (find-symbols parsed-symbol-name package rest-time-limit (%make-duplicate-symbols-filter (remove package-matching found-packages))) @@ -261,9 +266,9 @@ (* 1000 (* comparasions (expt 10 -7)))))) ; msecs (defun %make-duplicate-symbols-filter (fuzzy-package-matchings) - ;; Returns a filter function that takes a symbol and which returns T - ;; only if no matching in FUZZY-PACKAGE-MATCHINGS represents the - ;; home-package of the. + ;; Returns a filter function that takes a symbol, and which returns T + ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents + ;; the home-package of the symbol passed. (let ((packages (mapcar #'(lambda (m) (find-package (fuzzy-matching.package-name m))) (coerce fuzzy-package-matchings 'list)))) @@ -285,7 +290,7 @@ (name2 (symbol-name (fuzzy-matching.symbol m2)))) (string< name1 name2)))))) - +(declaim (ftype (function () (integer 0)) get-real-time-msecs)) (defun get-real-time-in-msecs () (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value! Modified: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries Mon Jan 28 06:47:40 2008 @@ -1,9 +1,9 @@ -/.cvsignore/1.1/Thu Oct 11 14:10:24 2007// -/Makefile/1.12/Thu Oct 11 14:10:24 2007// -/slime-refcard.pdf/1.1/Thu Oct 11 14:10:24 2007// -/slime-refcard.tex/1.1/Thu Oct 11 14:10:24 2007// -/slime-small.eps/1.1/Thu Oct 11 14:10:24 2007// -/slime-small.pdf/1.1/Thu Oct 11 14:10:24 2007// -/texinfo-tabulate.awk/1.2/Thu Oct 11 14:10:24 2007// -/slime.texi/1.61/Sun Dec 2 04:22:10 2007// +/.cvsignore/1.1/Mon Jul 24 14:13:23 2006// +/Makefile/1.12/Sun Jan 27 22:03:22 2008// +/slime-refcard.pdf/1.1/Sun Jan 27 22:03:22 2008// +/slime-refcard.tex/1.1/Sun Jan 27 22:03:22 2008// +/slime-small.eps/1.1/Sun Jan 27 22:03:22 2008// +/slime-small.pdf/1.1/Sun Jan 27 22:03:22 2008// +/slime.texi/1.64/Sun Jan 27 22:03:22 2008// +/texinfo-tabulate.awk/1.2/Sun Jan 27 22:03:22 2008// D Modified: branches/trunk-reorg/thirdparty/slime/doc/slime.texi ============================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime.texi (original) +++ branches/trunk-reorg/thirdparty/slime/doc/slime.texi Mon Jan 28 06:47:40 2008 @@ -12,7 +12,7 @@ @set EDITION 3.0-alpha @set SLIMEVER 3.0-alpha @c @set UPDATED @today{} -@set UPDATED @code{$Date: 2007/11/27 13:16:52 $} +@set UPDATED @code{$Date: 2008/01/20 16:57:49 $} @set TITLE SLIME User Manual @settitle @value{TITLE}, version @value{EDITION} @@ -1347,7 +1347,7 @@ @c @kbditem{C-c M-g, slime-quit} @c Quit slime. -@kbditem{C-c C-t, slime-repl-clear-buffer} +@kbditem{C-c M-o, slime-repl-clear-buffer} Clear the entire buffer, leaving only a prompt. @kbditem{C-c C-o, slime-repl-clear-output} @@ -2188,7 +2188,7 @@ @node Contributed Packages @chapter Contributed Packages -In version 3.0 we moved some functionility to separate packages. This +In version 3.0 we moved some functionality to separate packages. This chapter tells you how to load contrib modules and describes what the particular packages do. @@ -2237,7 +2237,7 @@ available. @node Compound Completion -@section Compund Completion +@section Compound Completion @anchor{slime-complete-symbol*} The package @code{slime-c-p-c} provides a different symbol completion @@ -2270,14 +2270,40 @@ @code{slime-c-p-c-unambiguous-prefix-p} is nil, point moves to the end of the inserted text, after the @code{o} in this case. +In addition, @code{slime-c-p-c} provides completion for character names +(mostly useful for Unicode-aware implementations): + +@example +CL-USER> #\Sp<TAB> +@end example + +Here SLIME will usually complete the character to @code{#\Space}, but +in a Unicode-aware implementation, this might provide the following completions: +@example +Space Space +Sparkle Spherical_Angle +Spherical_Angle_Opening_Left Spherical_Angle_Opening_Up +@end example + +The package @code{slime-c-p-c} also provides context-sensitive completion for keywords. +Example: + +@example +CL-USER> (find 1 '(1 2 3) :s<TAB> +@end example + +Here SLIME will complete @code{:start}, rather than suggesting all +ever-interned keywords starting with @code{:s}. + + @table @kbd @kbditem{C-c C-s, slime-complete-form} Looks up and inserts into the current buffer the argument list for the function at point, if there is one. More generally, the command completes an incomplete form with a template for the missing arguments. There is special code for discovering extra keywords of generic -functions and for handling @code{make-instance} and -@code{defmethod}. Examples: +functions and for handling @code{make-instance}, +@code{defmethod}, and many other functions. Examples: @example (subseq "abc" <C-c C-s> @@ -2472,26 +2498,138 @@ Right-clicking on the text brings up a menu with operations for the particular object. Some operations, like inspecting, are available for all objects, but the object may also have specialized operations. -E.g. pathnames have a dired operation. +For instance, pathnames have a dired operation. + +More importantly, it is possible to cut and paste presentations (i.e., +Lisp objects, not just their printed presentation), using all standard +Emacs commands. This way it is possible to cut and paste the results of +previous computations in the REPL. This is of particular importance for +unreadable objects. The package @code{slime-presentations} installs presentations in the -REPL, i.e. the results of evaluation commands become presentations. +REPL, i.e. the results of evaluation commands become presentations. In +this way, presentations generalize the use of the standard Common Lisp +REPL history variables @code{*}, @code{**}, @code{***}. Example: + +@example +CL-USER> (find-class 'standard-class) +@emph{#<STANDARD-CLASS STANDARD-CLASS>} +CL-USER> +@end example + +Presentations appear in red color in the buffer. +(In this manual, we indicate the presentations @emph{like this}.) +Using standard Emacs +commands, the presentation can be copied to a new input in the REPL: + +@example +CL-USER> (eql '@emph{#<STANDARD-CLASS STANDARD-CLASS>} '@emph{#<STANDARD-CLASS STANDARD-CLASS>}) +@emph{T} +@end example + +When you copy an incomplete presentation or edit the text within a +presentation, the presentation changes to plain text, losing the +association with a Lisp object. In the buffer, this is indicated by +changing the color of the text from red to black. This can be undone. + +Presentations are also available in the inspector (all inspectable parts +are presentations) and the debugger (all local variables are +presentations). This makes it possible to evaluate expressions in the +REPL using objects that appear in local variables of some active +debugger frame; this can be more convenient than using @code{M-x +sldb-eval-in-frame}. @strong{Warning:} The presentations that stem from +the inspector and debugger are only valid as long as the corresponding +buffers are open. Using them later can cause errors or confusing +behavior. + +For some Lisp implementations you can also install the package +@code{slime-presentation-streams}, which enables presentations on the +Lisp @code{*standard-output*} stream and similar streams. This means +that not only results +of computations, but also some objects that are printed to the standard +output (as a side-effect of the computation) are associated with +presentations. Currently, all unreadable objects +and pathnames get printed as presentations. + +@example +CL-USER> (describe (find-class 'standard-object)) +@emph{#<STANDARD-CLASS STANDARD-OBJECT>} is an instance of + @emph{#<STANDARD-CLASS STANDARD-CLASS>}: + The following slots have :INSTANCE allocation: + PLIST NIL + FLAGS 1 + DIRECT-METHODS ((@emph{#<STANDARD-METHOD + SWANK::ALL-SLOTS-FOR-INSPECTOR + (STANDARD-OBJECT T)>} + ... +@end example + +Again, this makes it possible to inspect and copy-paste these objects. + +In addition to the standard Emacs commands, there are several keyboard +commands, a menu-bar menu, and a context menu to operate on +presentations. We describe the keyboard commands below; they are also +shown in the menu-bar menu. + +@table @kbd +@kbditem{C-c C-v SPC, slime-mark-presentation} +If point is within a presentation, move point to the beginning of the +presentation and mark to the end of the presentation. +This makes it possible to copy the presentation. + +@kbditem{C-c C-v w, slime-copy-presentation-at-point-to-kill-ring} +If point is within a presentation, copy the surrounding presentation +to the kill ring. + +@kbditem{C-c C-v r, slime-copy-presentation-at-point-to-repl} +If point is within a presentation, copy the surrounding presentation +to the REPL. + +@kbditem{C-c C-v d, slime-describe-presentation-at-point} +If point is within a presentation, describe the associated object. + +@kbditem{C-c C-v i, slime-inspect-presentation-at-point} +If point is within a presentation, inspect the associated object with +the SLIME inspector. + +@kbditem{C-c C-v n, slime-next-presentation} +Move point to the next presentation in the buffer. + +@kbditem{C-c C-v p, slime-previous-presentation} +Move point to the previous presentation in the buffer. -For some implementations you can also install -@code{slime-presentation-streams} which enables presentations on the -Lisp @code{*standard-output*} stream. E.g. printing a list to such a -stream will create presentions in the Emacs buffer. - -@table @kbd -@cmditem{slime-copy-or-inspect-presentation-at-mouse} -@cmditem{slime-inspect-presentation-at-mouse} -@cmditem{slime-copy-presentation-at-mouse} -@cmditem{slime-copy-presentation-at-mouse-to-point} -@cmditem{slime-copy-presentation-at-mouse-to-kill-ring} -@cmditem{slime-describe-presentation-at-mouse} -@cmditem{slime-pretty-print-presentation-at-mouse} -@cmditem{slime-clear-presentations} @end table +Similar operations are also possible from the context menu of every +presentation. Using @kbd{mouse-3} on a presentation, the context menu +opens and offers various commands. For some objects, specialized +commands are also offered. Users can define additional specialized +commands by defining a method for +@code{swank::menu-choices-for-presentation}. + + +@strong{Warning:} On Lisp implementations without weak hash tables, +all objects associated with presentations are protected from garbage +collection. If your Lisp image grows too large because of that, +use @kbd{C-c C-v M-o} (@code{slime-clear-presentations}) to remove these +associations. You can also use the command @kbd{C-c M-o} +(@code{slime-repl-clear-buffer}), which both clears the REPL buffer and +removes all associations of objects with presentations. + +@strong{Warning:} Presentations can confuse new users. + +@example +CL-USER> (cons 1 2) +@emph{(1 . 2)} +CL-USER> (eq '@emph{(1 . 2)} '@emph{(1 . 2)}) +@emph{T} +@end example + +One could have expected @code{NIL} here, because it looks like two +fresh cons cells are compared regarding object identity. +However, in the example the presentation @code{@emph{(1 . 2)}} was copied twice +to the REPL. Thus @code{EQ} is really invoked with the same object, +namely the cons cell that was returned by the first form entered in the +REPL. @node Typeout frames @section Typeout frames Modified: branches/trunk-reorg/thirdparty/slime/slime.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/slime.el (original) +++ branches/trunk-reorg/thirdparty/slime/slime.el Mon Jan 28 06:47:40 2008 @@ -495,9 +495,9 @@ (t name)))) (format "%s" (read name)))) -(defun slime-pretty-current-package () - "Retrun a prettied version of `slime-current-package'." - (let ((p (slime-current-package))) +(defun slime-pretty-find-buffer-package () + "Return a prettied version of `slime-find-buffer-package'." + (let ((p (slime-find-buffer-package))) (and p (slime-pretty-package-name p)))) (when slime-update-modeline-package @@ -1179,7 +1179,9 @@ (interactive) (let ((inferior-lisp-program (or command inferior-lisp-program)) (slime-net-coding-system (or coding-system slime-net-coding-system))) - (slime-start* (slime-read-interactive-args)))) + (slime-start* (cond ((and command (symbolp command)) + (slime-lisp-options command)) + (t (slime-read-interactive-args)))))) (defvar slime-inferior-lisp-program-history '() "History list of command strings. Used by `slime'.") @@ -2695,10 +2697,11 @@ (when (< slime-repl-input-start-mark (point)) (set-marker slime-repl-input-start-mark (point)))))) -(defun slime-repl-emit-result (string) +(defun slime-repl-emit-result (string &optional bol) ;; insert STRING and mark it as evaluation result (with-current-buffer (slime-output-buffer) (goto-char slime-repl-input-start-mark) + (when (and bol (not (bolp))) (insert "\n")) (slime-insert-propertized `(face slime-repl-result-face rear-nonsticky (face)) string) @@ -2873,7 +2876,8 @@ ("\C-c\C-w" slime-who-map) ("\C-\M-x" 'slime-eval-defun) ("\C-c\C-o" 'slime-repl-clear-output) - ("\C-c\C-t" 'slime-repl-clear-buffer) + ("\C-c\M-o" 'slime-repl-clear-buffer) + ("\C-c\C-t" 'slime-toggle-trace-fdefinition) ("\C-c\C-u" 'slime-repl-kill-input) ("\C-c\C-n" 'slime-repl-next-prompt) ("\C-c\C-p" 'slime-repl-previous-prompt) @@ -2945,14 +2949,11 @@ (when result (destructure-case result ((:values &rest strings) - (unless (bolp) (insert "\n")) (cond ((null strings) - (insert "; No value\n")) + (slime-repl-emit-result "; No value\n" t)) (t - (dolist (string strings) - (slime-propertize-region `(face slime-repl-result-face) - (insert string)) - (insert "\n"))))))) + (dolist (s strings) + (slime-repl-emit-result s t))))))) (slime-repl-insert-prompt))) (defun slime-repl-show-abort () @@ -3312,7 +3313,7 @@ (defun slime-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." (interactive (list (slime-read-package-name - "Package: " (slime-pretty-current-package)))) + "Package: " (slime-pretty-find-buffer-package)))) (with-current-buffer (slime-output-buffer) (let ((unfinished-input (slime-repl-current-input))) (destructuring-bind (name prompt-string) @@ -5868,7 +5869,8 @@ (defun slime-apropos (string &optional only-external-p package case-sensitive-p) - "Show all bound symbols whose names match STRING, a regular expression." + "Show all bound symbols whose names match STRING. With prefix +arg, you're interactively asked for parameters of the search." (interactive (if current-prefix-arg (list (read-string "SLIME Apropos: ") @@ -5888,7 +5890,7 @@ (lambda (r) (slime-show-apropos r string package summary)))))) (defun slime-apropos-all () - "Shortcut for (slime-apropos <pattern> nil nil)" + "Shortcut for (slime-apropos <string> nil nil)" (interactive) (slime-apropos (read-string "SLIME Apropos: ") nil nil)) @@ -5931,10 +5933,7 @@ (dolist (plist plists) (let ((designator (plist-get plist :designator))) (assert designator) - (slime-insert-propertized (list 'face apropos-symbol-face - 'item designator - 'action 'slime-describe-symbol) - designator)) + (slime-insert-propertized `(face ,apropos-symbol-face) designator)) (terpri) (let ((apropos-label-properties slime-apropos-label-properties)) (loop for (prop namespace) @@ -6080,15 +6079,23 @@ (list 'slime-location location 'face 'font-lock-keyword-face) " " (slime-one-line-ify label)) - do (insert " - " (if (and (eql :location (car location)) - (assoc :file (cdr location))) - (second (assoc :file (cdr location))) - "file unknown") - "\n")))) + do (insert " - " (slime-insert-xref-location location) "\n")))) ;; Remove the final newline to prevent accidental window-scrolling (backward-char 1) (delete-char 1)) +(defun slime-insert-xref-location (location) + (if (eql :location (car location)) + (cond ((assoc :file (cdr location)) + (second (assoc :file (cdr location)))) + ((assoc :buffer (cdr location)) + (let* ((name (second (assoc :buffer (cdr location)))) + (buffer (get-buffer name))) + (if buffer + (format "%S" buffer) + (format "%s (previously existing buffer)" name))))) + "file unknown")) + (defvar slime-next-location-function nil "Function to call for going to the next location.") @@ -6287,9 +6294,7 @@ ("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package (slime-macroexpansion-minor-mode) (erase-buffer) - (save-excursion - (insert expansion)) - (indent-sexp) + (insert expansion) (font-lock-fontify-buffer)))))) (defun slime-eval-macroexpand-inplace (expander) @@ -6318,59 +6323,7 @@ (indent-sexp) (goto-char point)))))))) -(defun slime-enclosing-macro-context-establishers () - (flet ((establishes-context-p (form-spec) - (let ((operator-name (first form-spec))) - (when (stringp operator-name) - (let ((symbol-name (slime-cl-symbol-name operator-name))) - (or (equal symbol-name "macrolet") (equal symbol-name "symbol-macrolet"))))))) - (multiple-value-bind (form-specs indices points) - (slime-enclosing-form-specs) - (loop for form-spec in form-specs - for index in indices - for point in points - when (establishes-context-p form-spec) - collect form-spec into form-specs* and - collect index into indices* and - collect point into points* - finally (return (values form-specs* indices* points*)))))) - -(defun slime-collect-macro-context () - (multiple-value-bind (form-specs indices points) - (slime-enclosing-macro-context-establishers) - (save-excursion - (let ((context)) - (cl-mapc #'(lambda (form-spec index point) - (when (= index 2) - (destructuring-bind (operator-name) form-spec - (goto-char point) - (slime-forward-sexp) - (forward-char) - (push (cons operator-name (slime-parse-sexp-at-point 1 t)) context)))) - form-specs indices points) - context)))) - -(defun slime-rebuild-macro-context-around-string (string context) - (if (null context) - string - (destructuring-bind (let-operator . bindings) (first context) - (format "(%s %s %s)" let-operator bindings - (slime-rebuild-macro-context-around-string string (rest context)))))) - -(defun slime-macroexpand-locally-1 (&optional repeatedly) - (interactive "P") - (let ((sexp (first (slime-sexp-at-point-for-macroexpansion))) - (macro-context (slime-collect-macro-context))) - (if repeatedly - (slime-eval-macroexpand 'swank:swank-macroexpand-locally - (slime-rebuild-macro-context-around-string - (format "(swank::macroexpand-locally %s)" sexp) - macro-context)) - (slime-eval-macroexpand 'swank:swank-macroexpand-locally-1 - (slime-rebuild-macro-context-around-string - (format "(swank::macroexpand-locally-1 %s)" sexp) - macro-context))))) - + (defun slime-macroexpand-1 (&optional repeatedly) "Display the macro expansion of the form at point. The form is expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with @@ -6440,8 +6393,8 @@ (message "Connection closed."))) (defun slime-set-package (package) - (interactive (list (slime-read-package-name "Package: " - (slime-pretty-current-package)))) + (interactive (list (slime-read-package-name + "Package: " (slime-pretty-find-buffer-package)))) (message "*package*: %s" (slime-eval `(swank:set-package ,package)))) (defun slime-set-default-directory (directory) @@ -7105,6 +7058,8 @@ (destructuring-bind (start end) (sldb-frame-region) (list start end frame locals catches)))) +(defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value) + (defun sldb-insert-locals (vars prefix frame) "Insert VARS and add PREFIX at the beginning of each inserted line. VAR should be a plist with the keys :name, :id, and :value." @@ -7117,7 +7072,11 @@ (in-sldb-face local-name (concat name (if (zerop id) "" (format "#%d" id)))) " = ") - (insert (in-sldb-face local-value value) "\n"))))) + (funcall sldb-insert-frame-variable-value-function value frame i) + (insert "\n"))))) + +(defun sldb-insert-frame-variable-value (value frame index) + (insert (in-sldb-face local-value value))) (defun sldb-hide-frame-details () ;; delete locals and catch tags, but keep the function name and args. @@ -7329,19 +7288,17 @@ (defun slime-list-threads () "Display a list of threads." (interactive) - (slime-eval-async - '(swank:list-threads) - (lambda (threads) - (with-current-buffer (get-buffer-create "*slime-threads*") - (slime-thread-control-mode) - (let ((inhibit-read-only t)) - (erase-buffer) - (loop for idx from 0 - for (name status id) in threads - do (slime-thread-insert idx name status id)) - (goto-char (point-min)) - (setq buffer-read-only t) - (pop-to-buffer (current-buffer))))))) + (let ((threads (slime-eval '(swank:list-threads)))) + (with-current-buffer (get-buffer-create "*slime-threads*") + (slime-thread-control-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (loop for idx from 0 + for (name status id) in threads + do (slime-thread-insert idx name status id)) + (goto-char (point-min)) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer)))))) (defun slime-thread-insert (idx name summary id) (slime-propertize-region `(thread-id ,idx) @@ -7550,6 +7507,8 @@ (defmacro slime-inspector-fontify (face string) `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) +(defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec) + (defun slime-open-inspector (inspected-parts &optional point) "Display INSPECTED-PARTS in a new inspector window. Optionally set point to POINT." @@ -7557,21 +7516,19 @@ (setq slime-buffer-connection (slime-current-connection)) (let ((inhibit-read-only t)) (erase-buffer) - (destructuring-bind (&key string-representation id title content) inspected-parts + (destructuring-bind (&key id title content) inspected-parts (macrolet ((fontify (face string) `(slime-inspector-fontify ,face ,string))) (slime-propertize-region (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) - (insert string-representation)) - (insert ":\n ") - (insert (fontify topline title)) + (insert title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" (fontify label "--------------------") "\n") (save-excursion - (mapc #'slime-inspector-insert-ispec content)) + (mapc slime-inspector-insert-ispec-function content)) (pop-to-buffer (current-buffer)) (when point (check-type point cons) @@ -7870,7 +7827,6 @@ (def-slime-selector-method ?t "SLIME threads buffer." (slime-list-threads) - (slime-eval `(cl:quote nil)) ;wait until slime-list-threads returns "*slime-threads*") (defun slime-recently-visited-buffer (mode) @@ -8481,6 +8437,9 @@ (defun slime-wait-condition (name predicate timeout) (let ((end (time-add (current-time) (seconds-to-time timeout)))) (while (not (funcall predicate)) + (let ((now (current-time))) + (message "waiting for condition: %s [%s.%06d]" name + (format-time-string "%H:%M:%S" now) (third now))) (cond ((time-less-p end (current-time)) (error "Timeout waiting for condition: %S" name)) (t @@ -8666,7 +8625,10 @@ (cl-user::bar)) " - (cl-user::bar))) + (cl-user::bar)) + ("(defun foo () + #+#.'(:and) (/ 1 0))" + (/ 1 0))) (slime-check-top-level) (with-temp-buffer (lisp-mode) @@ -8698,9 +8660,9 @@ (sldb-quit) ;; Going down - enter another recursive debug ;; Recursively debug. - (slime-eval-async 'no-such-variable))))))) + (slime-eval-async '(error)))))))) (let ((sldb-hook (cons debug-hook sldb-hook))) - (slime-eval-async 'no-such-variable) + (slime-eval-async '(error)) (slime-sync-to-top-level 5) (slime-check-top-level) (slime-check ("Maximum depth reached (%S) is %S." @@ -9013,24 +8975,31 @@ (not (not (get-buffer-window (current-buffer))))))) (def-slime-test break - () + (times) "Test if BREAK invokes SLDB." - '(()) + '((1) (2) (3)) (slime-accept-process-output nil 1) (slime-check-top-level) - (slime-compile-string (prin1-to-string '(cl:defun cl-user::foo () - (cl:break))) - 0) + (slime-compile-string + (prin1-to-string `(defun cl-user::foo () + (dotimes (i ,times) + (break) + (sleep 0.2)))) + 0) (slime-sync-to-top-level 2) (slime-eval-async '(cl-user::foo)) - (slime-wait-condition "Debugger visible" - (lambda () - (and (slime-sldb-level= 1) - (get-buffer-window (sldb-get-default-buffer)))) - 5) - (with-current-buffer (sldb-get-default-buffer) - (sldb-quit)) - (slime-accept-process-output nil 1) + (dotimes (i times) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window + (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "sldb closed" + (lambda () (not (sldb-get-default-buffer))) + 0.2)) (slime-sync-to-top-level 5)) (def-slime-test interrupt-at-toplevel @@ -9129,21 +9098,6 @@ (list (nthcdr n seq)) (seq (> (length seq) n)))) -(defun slime-split-string (string &optional separators omit-nulls) - "This is like `split-string' in Emacs22, but also works in -Emacs20 and 21." - (let ((splits (split-string string separators))) - (if omit-nulls - (setq splits (remove "" splits)) - ;; SPLIT-STRING in Emacs before 22.x automatically removed nulls - ;; at beginning and end, so we gotta add them here again. - (when (or (slime-emacs-20-p) (slime-emacs-21-p)) - (when (find (elt string 0) separators) - (push "" splits)) - (when (find (elt string (1- (length string))) separators) - (setq splits (append splits (list "")))))) - splits)) - ;;;;; Buffer related (defun slime-buffer-narrowed-p (&optional buffer) @@ -9241,6 +9195,32 @@ (when (featurep 'xemacs) (require 'overlay)) +(defun slime-split-string (string &optional separators omit-nulls) + "This is like `split-string' in Emacs22, but also works in +Emacs20 and 21." + (let ((splits (split-string string separators))) + (if omit-nulls + (setq splits (remove "" splits)) + ;; SPLIT-STRING in Emacs before 22.x automatically removed nulls + ;; at beginning and end, so we gotta add them here again. + (when (or (slime-emacs-20-p) (slime-emacs-21-p)) + (when (find (elt string 0) separators) + (push "" splits)) + (when (find (elt string (1- (length string))) separators) + (setq splits (append splits (list "")))))) + splits)) + +(defun slime-delete-and-extract-region (start end) + "Like `delete-and-extract-region' except that it is guaranteed +to return a string. At least Emacs 21.3.50 returned `nil' on +\(delete-and-extract-region (point) (point)), this function +will return \"\"." + (let ((result (delete-and-extract-region start end))) + (if (null result) + "" + (assert (stringp result)) + result))) + (defmacro slime-defun-if-undefined (name &rest rest) ;; We can't decide at compile time whether NAME is properly ;; bound. So we delay the decision to runtime to ensure some Modified: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp Mon Jan 28 06:47:40 2008 @@ -157,6 +157,19 @@ (typecase name (generic-function (clos::generic-function-lambda-list name)) + (compiled-function + ; most of the compiled functions have an Args: line in their docs + (with-input-from-string (s (or + (si::get-documentation + (si:compiled-function-name name) 'function) + "")) + (do ((line (read-line s nil) (read-line s nil))) + ((not line) :not-available) + (ignore-errors + (if (string= (subseq line 0 6) "Args: ") + (return-from nil + (read-from-string (subseq line 6)))))))) + ; (function (let ((fle (function-lambda-expression name))) (case (car fle) @@ -241,6 +254,210 @@ (defimplementation make-default-inspector () (make-instance 'ecl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (values + (format nil "~S is an ordinary stream" o) + (append + (list + "Open for " + (cond + ((ignore-errors (interactive-stream-p o)) "Interactive") + ((and (input-stream-p o) (output-stream-p o)) "Input and output") + ((input-stream-p o) "Input") + ((output-stream-p o) "Output")) + `(:newline) `(:newline)) + (label-value-line* + ("Element type" (stream-element-type o)) + ("External format" (stream-external-format o))) + (ignore-errors (label-value-line* + ("Broadcast streams" (broadcast-stream-streams o)))) + (ignore-errors (label-value-line* + ("Concatenated streams" (concatenated-stream-streams o)))) + (ignore-errors (label-value-line* + ("Echo input stream" (echo-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Echo output stream" (echo-stream-output-stream o)))) + (ignore-errors (label-value-line* + ("Output String" (get-output-stream-string o)))) + (ignore-errors (label-value-line* + ("Synonym symbol" (synonym-stream-symbol o)))) + (ignore-errors (label-value-line* + ("Input stream" (two-way-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Output stream" (two-way-stream-output-stream o))))))) + (t + (let* ((cl (si:instance-class o)) + (slots (clos:class-slots cl))) + (values (format nil "~S is an instance of class ~A" + o (clos::class-name cl)) + (loop for x in slots append + (let* ((name (clos:slot-definition-name x)) + (value (clos::slot-value o name))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))))) + ;;;; Definitions (defimplementation find-definitions (name) nil) + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (mp:make-lock :name "thread id counter lock")) + + (defun next-thread-id () + (mp:with-lock (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + ; ecl doesn't have weak pointers + (defimplementation spawn (fn &key name) + (let ((thread (mp:make-process :name name)) + (id (next-thread-id))) + (mp:process-preset + thread + #'(lambda () + (unwind-protect + (mp:with-lock (*thread-id-map-lock*) + (setf (gethash id *thread-id-map*) thread)) + (funcall fn) + (mp:with-lock (*thread-id-map-lock*) + (remhash id *thread-id-map*))))) + (mp:process-enable thread))) + + (defimplementation thread-id (thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do (if (eq thread thread-pointer) + (return-from thread-id id)))))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (gethash id *thread-id-map*))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-lock :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation make-recursive-lock (&key name) + (mp:make-lock :name name)) + + (defimplementation call-with-recursive-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:interrupt-process + thread + (lambda () + (mp:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))))) + + (defimplementation receive () + (block got-mail + (let* ((mbox (mailbox mp:*current-process*)) + (mutex (mailbox.mutex mbox))) + (loop + (mp:with-lock (mutex) + (if (mailbox.queue mbox) + (return-from got-mail (pop (mailbox.queue mbox))))) + ;interrupt-process will halt this if it takes longer than 1sec + (sleep 1))))) + + ;; Auto-flush streams + (defvar *auto-flush-interval* 0.15 + "How often to flush interactive streams. This valu is passed + directly to cl:sleep.") + + (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush")) + + (defvar *auto-flush-thread* nil) + + (defvar *auto-flush-streams* '()) + + (defimplementation make-stream-interactive (stream) + (call-with-recursive-lock-held + *auto-flush-lock* + (lambda () + (pushnew stream *auto-flush-streams*) + (unless *auto-flush-thread* + (setq *auto-flush-thread* + (spawn #'flush-streams + :name "auto-flush-thread")))))) + + (defmethod stream-finish-output ((stream stream)) + (finish-output stream)) + + (defun flush-streams () + (loop + (call-with-recursive-lock-held + *auto-flush-lock* + (lambda () + (setq *auto-flush-streams* + (remove-if (lambda (x) + (not (and (open-stream-p x) + (output-stream-p x)))) + *auto-flush-streams*)) + (mapc #'stream-finish-output *auto-flush-streams*))) + (sleep *auto-flush-interval*))) + + ) + Modified: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp Mon Jan 28 06:47:40 2008 @@ -236,8 +236,9 @@ (eql (mismatch "SB-" name) 3))) (defun sbcl-source-file-p (filename) - (loop for (_ pattern) in (logical-pathname-translations "SYS") - thereis (pathname-match-p filename pattern))) + (when filename + (loop for (_ pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern)))) (defun guess-readtable-for-filename (filename) (if (sbcl-source-file-p filename) @@ -831,16 +832,19 @@ (defun source-file-source-location (code-location) (let* ((code-date (code-location-debug-source-created code-location)) (filename (code-location-debug-source-name code-location)) + (*readtable* (guess-readtable-for-filename filename)) (source-code (get-source-code filename code-date))) - (with-input-from-string (s source-code) - (let* ((pos (stream-source-position code-location s)) - (snippet (read-snippet s pos))) - (make-location `(:file ,filename) - `(:position ,(1+ pos)) - `(:snippet ,snippet)))))) + (with-debootstrapping + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,(1+ pos)) + `(:snippet ,snippet))))))) (defun code-location-debug-source-name (code-location) - (sb-c::debug-source-name (sb-di::code-location-debug-source code-location))) + (namestring (truename (sb-c::debug-source-name + (sb-di::code-location-debug-source code-location))))) (defun code-location-debug-source-created (code-location) (sb-c::debug-source-created Modified: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp Mon Jan 28 06:47:40 2008 @@ -53,7 +53,8 @@ (check-type timeout (or null real)) (if (fboundp 'ext::stream-timeout) (setf (ext::stream-timeout stream) timeout) - (setf (slot-value (slot-value stream 'cl::stream) 'cl::timeout) timeout))) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) ;;;;; Sockets @@ -87,7 +88,8 @@ :external-format external-format))) ;; Ignore character conversion errors. Without this the communication ;; channel is prone to lockup if a character conversion error occurs. - (setf (cl::stream-character-conversion-error-value stream) #\?) + (setf (lisp::character-conversion-stream-input-error-value stream) #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) #\?) stream)) Modified: branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp Mon Jan 28 06:47:40 2008 @@ -56,20 +56,8 @@ (when fn (set-macro-character char (make-source-recorder fn source-map) term tab))))) - (suppress-sharp-dot tab) tab)) -(defun suppress-sharp-dot (readtable) - (when (get-macro-character #\# readtable) - (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable))) - (set-dispatch-macro-character #\# #\. (lambda (&rest args) - (let ((*read-suppress* t)) - (apply sharp-dot args)) - (if *read-suppress* - (values) - (list (gensym "#.")))) - readtable)))) - (defun read-and-record-source-map (stream) "Read the next object from STREAM. Return the object together with a hashtable that maps @@ -90,8 +78,7 @@ (let ((*read-suppress* t)) (dotimes (i n) (read stream))) - (let ((*read-suppress* nil) - (*read-eval* nil)) + (let ((*read-suppress* nil)) (read-and-record-source-map stream))) (defun source-path-stream-position (path stream) Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp Mon Jan 28 06:47:40 2008 @@ -78,8 +78,7 @@ "Abbreviate dotted package names to their last component if T.") (defvar *swank-io-package* - (let ((package (or (find-package :swank-io-package) - (make-package :swank-io-package :use '())))) + (let ((package (make-package :swank-io-package :use '()))) (import '(nil t quote) package) package)) @@ -1582,7 +1581,7 @@ compound forms like lists or vectors.)" (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) (if found? - (values symbol nil) + (values symbol (length string) nil) (multiple-value-bind (sexp pos) (read-from-string string) (values sexp pos (when (symbolp sexp) @@ -2402,22 +2401,6 @@ (let ((*print-readably* nil)) (disassemble (fdefinition (from-string name))))))) -(defslimefun swank-macroexpand-locally (string) - (apply-macro-expander #'eval string)) - -(defslimefun swank-macroexpand-locally-1 (string) - (apply-macro-expander #'eval string)) - -(defmacro macroexpand-locally (form &environment env) - (multiple-value-bind (expansion expanded-p) - (macroexpand form env) - `(values ',expansion ',expanded-p))) - -(defmacro macroexpand-locally-1 (form &environment env) - (multiple-value-bind (expansion expanded-p) - (macroexpand-1 form env) - `(values ',expansion ',expanded-p))) - ;;;; Simple completion @@ -2984,11 +2967,10 @@ (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (multiple-value-bind (title content) (inspect-for-emacs object inspector) - (list :title title - :string-representation - (with-output-to-string (stream) - (print-unreadable-object (object stream :type t :identity t))) + (multiple-value-bind (_ content) (inspect-for-emacs object inspector) + (declare (ignore _)) + (list :title (with-output-to-string (s) + (print-unreadable-object (object s :type t :identity t))) :id (assign-index object *inspectee-parts*) :content (inspector-content-for-emacs content)))))

1 0