@@ -23,7 +23,7 @@ ;; Suite 330, Boston, MA 02111-1307 USA ;; ;; -;; $Id: examples.cl,v 1.40 2007/04/17 22:05:04 layer Exp $ +;; $Id: examples.cl,v 1.41 2008/02/04 19:03:59 jkf Exp $ ;; Description: ;; Allegro iServe examples @@ -74,7 +74,9 @@ :p (:b "Sample pages") :br ((:a :href "gc") "Garbage Collector Stats") :br - ((:a :href "apropos") "Apropos") + ((:a :href "apropos") "Apropos using get") + :br + ((:a :href "apropos-post") "Apropos using post") :br ((:a :href "pic") "Sample jpeg") :br ((:a :href "pic-redirect") "Redirect to previous picture") :br @@ -412,6 +414,64 @@ else (html "Enter name and type enter"))) :newline)))))) +(publish + :path "/apropos-post" + :content-type "text/html" + :function + #'(lambda (req ent) + (let ((lookup (assoc "symbol" (request-query req) :test #'equal))) + (with-http-response (req ent) + (with-http-body (req ent) + (html (:head (:title "Allegro Apropos")) + ((:body :background "aserveweb/fresh.jpg") + "New Apropos of " + ((:form :action "apropos-post" + :method "post") + ((:input :type "text" + :maxlength 40 + :size 20 + :name "symbol"))) + #+allegro + " The apropos function in ACL is case sensitive." + :p + + (if* lookup + then (html :hr (:b "Apropos") " of " + (:princ-safe (cdr lookup)) + :br + :br) + (let ((ans (apropos-list (cdr lookup)))) + (if* (null ans) + then (html "No Match Found") + else (macrolet ((my-td (str) + `(html ((:td + :bgcolor "blue") + ((:font :color "white" + :size "+1") + (:b ,str)))))) + + (html ((:table + :bgcolor "silver" + :bordercolor "blue" + :border 3 + :cellpadding 3 + ) + + (:tr + (my-td "Symbol") + (my-td "boundp") + (my-td "fboundp")) + + + (dolist (val ans) + (html (:tr + (:td (:prin1-safe val)) + (:td (:prin1 (and (boundp val) t))) + (:td (:prin1 (and (fboundp val) t)))) + :newline))))))) + else (html "Enter name and type enter"))) + :newline)))))) + ;; a preloaded picture file (publish-file :path "/aserveweb/fresh.jpg" examples/examples.cl @@ -24,7 +24,7 @@ ;; Suite 330, Boston, MA 02111-1307 USA ;; ;; -;; $Id: log.cl,v 1.26 2007/04/17 22:05:04 layer Exp $ +;; $Id: log.cl,v 1.27 2008/02/04 19:03:59 jkf Exp $ ;; Description: ;; iserve's logging @@ -37,6 +37,8 @@ (defvar *enable-logging* t) ; to turn on/off the standard logging method +(defvar *save-commands* nil) ; if true then a stream to which to write commands + (defmethod logmess (message) ;; send log message to the default vhost's error stream (logmess-stream message (vhost-error-stream @@ -137,7 +139,30 @@ ; get the stream again (setq stream (vhost-log-stream (request-vhost req))) (do-log)) - else (do-log)))))) + else (do-log))))) + + (if* *save-commands* + then (multiple-value-bind (ok whole uri-string) + (match-re "^[^ ]+\\s+([^ ]+)" (request-raw-request req)) + (declare (ignore ok whole)) + (format *save-commands* + "((:method . ~s) (:uri . ~s) (:proto . ~s) ~% (:code . ~s)~@[~% (:body . ~s)~]~@[~% (:auth . ~s)~]~@[~% (:ctype . ~s)~])~%" + (request-method req) + uri-string + (request-protocol req) + (let ((obj (request-reply-code req))) + (if* obj + then (response-number obj) + else 999)) + (let ((bod (request-request-body req))) + (and (not (equal "" bod)) bod)) + (multiple-value-list (get-basic-authorization req)) + (header-slot-value req :content-type) + )) + (force-output *save-commands*)) + + + ) log.cl d4267a326db86ceef80b2e50c1b2c51034da64b5 jkf jkf http://github.com/franzinc/aserve/commit/3f9e5362951bd2b17629c9856e82f01507af24ed 3f9e5362951bd2b17629c9856e82f01507af24ed 2008-02-04T11:03:59-08:00 2008-02-04T11:03:59-08:00 checkpoint 417f10a9bdb2a5a52a8f87aaed7afe50f3a39eb3 jkf jkf