[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
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
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
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
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
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
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
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
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
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
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>
+
+ <p>CL-SMTP is a simple lisp Networking Library that provides SMTP client protocol, supported LOGIN and PLAIN authentication methods.</p>
+
+ <p><b>New Version</b> [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.</p>
+
+ <h3>Download</h3>
+
+ <p>ASDF package <a href="cl-smtp.tar.gz">cl-smtp.tar.gz</a></p>
+
+ <h3>CVS</h3>
+
+ <p>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></p>
+
+ <h3>Portability</h3>
+
+ <p>CL-SMTP requires USOCKET and CL-BASE64 (CL-BASE64 isn't a requirement on ACL)</p>
+ <p>It works in all implementations supported by its dependencies (Allegro, SBCL, CMU CL, OpenMCL, Lispworks, CLISP and ECL).</p>
+ <p>Test results for Linux/x86/amd64:</p>
+ <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><br/>for developers</li>
+ <li>
+ <a
+ href="http://www.common-lisp.net/mailman/listinfo/cl-smtp-cvs">
+ CL-SMTP-cvs</a><br/>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