October 2003 - clhp-cvs@common-lisp.net - mailman3.common-lisp.net

[clhp-cvs] CVS update: clhp/tests/.cvsignore
by Anthony Ventimiglia 14 Oct '03

14 Oct '03

Update of /project/clhp/cvsroot/clhp/tests In directory common-lisp.net:/tmp/cvs-serv11421/tests Added Files: .cvsignore Log Message: Date: Tue Oct 14 00:33:40 2003 Author: aventimiglia

1 0

[clhp-cvs] CVS update: clhp/.cvsignore
by Anthony Ventimiglia 14 Oct '03

14 Oct '03

Update of /project/clhp/cvsroot/clhp In directory common-lisp.net:/tmp/cvs-serv11421 Added Files: .cvsignore Log Message: Date: Tue Oct 14 00:33:41 2003 Author: aventimiglia

1 0

[clhp-cvs] CVS update: clhp/examples/.cvsignore
by Anthony Ventimiglia 14 Oct '03

14 Oct '03

Update of /project/clhp/cvsroot/clhp/examples In directory common-lisp.net:/tmp/cvs-serv11421/examples Added Files: .cvsignore Log Message: Date: Tue Oct 14 00:33:41 2003 Author: aventimiglia

1 0

[clhp-cvs] CVS update: clhp/clhp.lisp clhp/cgi.lisp clhp/ChangeLog
by Anthony Ventimiglia 08 Oct '03

08 Oct '03

Update of /project/clhp/cvsroot/clhp In directory common-lisp.net:/tmp/cvs-serv29753 Modified Files: clhp.lisp cgi.lisp ChangeLog Log Message: (cond-bind): Addedd COND-BIND, basically it's a COND wrapped up inside a LET. Imported into clhp, and used there as well. (IF-BIND): This is similar to COND-BIND, the whole aim here is to reduce parentheses and make it all a little more readable Date: Wed Oct 8 11:43:33 2003 Author: aventimiglia Index: clhp/clhp.lisp diff -u clhp/clhp.lisp:1.10 clhp/clhp.lisp:1.11 --- clhp/clhp.lisp:1.10 Thu Oct 2 22:40:39 2003 +++ clhp/clhp.lisp Wed Oct 8 11:43:33 2003 @@ -1,5 +1,5 @@ (ext:file-comment - "$Id: clhp.lisp,v 1.10 2003/10/03 02:40:39 aventimiglia Exp $") + "$Id: clhp.lisp,v 1.11 2003/10/08 15:43:33 aventimiglia Exp $") ;; ;; CLHP the Common Lisp Hypertext Preprocessor ;; (C) 2003 Anthony J Ventimiglia @@ -27,6 +27,7 @@ (defpackage :clhp (:use :cgi :cl) + (:import-from :cgi #:cond-bind #:list-to-a-list) (:export #:parse #:*clhp-version* #:echo #:include #:xml-element #:make-xml-element #:copy-xml-element #:xml-element-attributes #:xml-element-name #:xml-element-contents #:xml-element-p #:tag)) @@ -38,7 +39,7 @@ ;; will override the CVS keyword (defconstant *CLHP-VERSION* #.(or nil ; Set this for releases - (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/10/03 02:40:39 $")) + (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/10/08 15:43:33 $")) (date (subseq trimmed 0 (search " " trimmed)))) (concatenate 'string (subseq date 0 4) @@ -115,10 +116,9 @@ the <?clhp ?> elements, and dumps the rest through unscathed." (declare (type (array character 1) buffer) (type fixnum end)) - (let ((index (if in-block - (find-pi-end buffer :start start :end end) - (find-pi-start buffer :start start :end end)))) - (cond + (cond-bind ((index (if in-block + (find-pi-end buffer :start start :end end) + (find-pi-start buffer :start start :end end)))) ((>= start end) ; Done with this buffer nil) ((and in-block index) ; Found the end of a code-block @@ -135,7 +135,7 @@ :in-block t)) (in-block (signal 'parse-error)) (t ; Not in code-block no start in sight - (write-sequence buffer *standard-output* :start start :end end))))) + (write-sequence buffer *standard-output* :start start :end end)))) (defun evaluate-code-block (code-block) "Read the Lisp object represented by CODE-BLOCK, and evaluate it." @@ -198,7 +198,7 @@ --> <IMG SRC=\"pic.png\"></IMG>" (multiple-value-bind (att-list contents) - (cgi::list-to-a-list (cdr args)) + (list-to-a-list (cdr args)) (make-xml-element :name (car args) :attributes att-list :contents contents))) Index: clhp/cgi.lisp diff -u clhp/cgi.lisp:1.6 clhp/cgi.lisp:1.7 --- clhp/cgi.lisp:1.6 Thu Oct 2 22:40:39 2003 +++ clhp/cgi.lisp Wed Oct 8 11:43:33 2003 @@ -1,4 +1,4 @@ -#+cmu (ext:file-comment "$Id: cgi.lisp,v 1.6 2003/10/03 02:40:39 aventimiglia Exp $") +#+cmu (ext:file-comment "$Id: cgi.lisp,v 1.7 2003/10/08 15:43:33 aventimiglia Exp $") ;; ;; CLHP the Common Lisp Hypertext Preprocessor ;; (C) 2003 Anthony J Ventimiglia @@ -45,6 +45,15 @@ "returns the value from a (KEY . VALUE) A-LIST" `(cadr (assoc ,key ,a-list))) +(defmacro cond-bind ((&rest bindings) &body body) + "A COND wrapped in a Let" + `(let (,@bindings) (cond ,@body))) + +(defmacro if-bind ((&rest bindings) test if else) + "An IF wrapped in a LET" + `(let (,@bindings) (if ,test ,if ,else))) + + ;; External Symbol section (defvar *server-env* nil @@ -94,14 +103,14 @@ accessed" (setf *server-env* (ca-list-to-a-list ext:*environment-list*) *query-vars* - (let ((request-method (make-keyword + (cond-bind + ((request-method (make-keyword (a-list-value :REQUEST_METHOD *server-env*)))) - (cond - ((eql request-method :POST) - (query-to-a-list (post-data))) - ((eql request-method :GET) - (query-to-a-list (get-data)))))) + ((eql request-method :POST) + (query-to-a-list (post-data))) + ((eql request-method :GET) + (query-to-a-list (get-data))))) (values)) ;; @@ -129,12 +138,12 @@ (labels ((split (char-list split-list) - (let ((position (position char char-list))) - (if (null position) + (if-bind ((position (position char char-list))) + (null position) (remove nil (nreverse (cons char-list split-list))) (split (nthcdr (1+ position) char-list) (cons (butlast char-list (- (length char-list) position)) - split-list)))))) + split-list))))) (split char-list nil))) ;; !!!!!!!!! This should most likely be tested and improved , because @@ -202,35 +211,35 @@ :message (format nil "~S is a malformed URL encoded string." (implode-string char-list)))) - (decode-next (encoded-part &optional decoded-part) - (let ((front-char (car encoded-part))) - (cond - ((null encoded-part) (nreverse decoded-part)) - ((char= #\% front-char) - (if (<= 3 (length encoded-part)) - (decode-next (cdddr encoded-part) - (cons (decode-char - (subseq encoded-part 1 3)) - decoded-part)) - (decode-error))) - ((char= #\+ front-char) - (decode-next (cdr encoded-part) - (cons #\Space decoded-part))) - (t (decode-next (cdr encoded-part) - (cons front-char decoded-part)))))) + (decode-next + (encoded-part &optional decoded-part) + (cond-bind ((front-char (car encoded-part))) + ((null encoded-part) (nreverse decoded-part)) + ((char= #\% front-char) + (if (<= 3 (length encoded-part)) + (decode-next (cdddr encoded-part) + (cons (decode-char + (subseq encoded-part 1 3)) + decoded-part)) + (decode-error))) + ((char= #\+ front-char) + (decode-next (cdr encoded-part) + (cons #\Space decoded-part))) + (t (decode-next (cdr encoded-part) + (cons front-char decoded-part))))) (hex2dec (string-num) (setf *read-base* 16) (prog1 (read-from-string string-num) (setf *read-base* 10))) (decode-char (char-code-list) - (let ((great (car char-code-list)) - (least (cadr char-code-list))) - (if (and (digit-char-p great 16) - (digit-char-p least 16)) - (code-char (hex2dec - (format nil "~a~a" great least))) - (decode-error))))) + (if-bind ((great (car char-code-list)) + (least (cadr char-code-list))) + (and (digit-char-p great 16) + (digit-char-p least 16)) + (code-char (hex2dec + (format nil "~a~a" great least))) + (decode-error)))) (decode-next char-list)))) (defun implode-string (char-list) Index: clhp/ChangeLog diff -u clhp/ChangeLog:1.9 clhp/ChangeLog:1.10 --- clhp/ChangeLog:1.9 Fri Oct 3 01:14:23 2003 +++ clhp/ChangeLog Wed Oct 8 11:43:33 2003 @@ -1,3 +1,11 @@ +2003-10-08 <ant(a)afghan.dogpound> + + * cgi.lisp, clhp.lisp (cond-bind): Addedd COND-BIND, basically + it's a COND wrapped up inside a LET. Imported into clhp, and used + there as well. + (IF-BIND): This is similar to COND-BIND, the whole aim here is to + reduce parentheses and make it all a little more readable + 2003-10-03 <ant(a)afghan.dogpound> * tests/cgi-test.lisp (SIDE-EFFECT-FUNCTION-TEST-DATA): Test class @@ -54,4 +62,4 @@ used to create tables from (CONS . TYPE) a-lists. Also added some comments. -$Id: ChangeLog,v 1.9 2003/10/03 05:14:23 aventimiglia Exp $ \ No newline at end of file +$Id: ChangeLog,v 1.10 2003/10/08 15:43:33 aventimiglia Exp $ \ No newline at end of file

1 0

[clhp-cvs] CVS update: clhp/tests/cgi-test.lisp
by Anthony Ventimiglia 08 Oct '03

08 Oct '03

Update of /project/clhp/cvsroot/clhp/tests In directory common-lisp.net:/tmp/cvs-serv29753/tests Modified Files: cgi-test.lisp Log Message: (cond-bind): Addedd COND-BIND, basically it's a COND wrapped up inside a LET. Imported into clhp, and used there as well. (IF-BIND): This is similar to COND-BIND, the whole aim here is to reduce parentheses and make it all a little more readable Date: Wed Oct 8 11:43:32 2003 Author: aventimiglia Index: clhp/tests/cgi-test.lisp diff -u clhp/tests/cgi-test.lisp:1.5 clhp/tests/cgi-test.lisp:1.6 --- clhp/tests/cgi-test.lisp:1.5 Fri Oct 3 01:14:23 2003 +++ clhp/tests/cgi-test.lisp Wed Oct 8 11:43:32 2003 @@ -96,12 +96,6 @@ (:documentation "A subclass of function-test-data used to test functions which have side effects of setting global variables.")) - -(defmethod run-test ((data test-data) &optional stream) - "Since TEST-DATA is an abstract test class, we cannot actually use it." - (declare (ignore stream)) - (test-result :error)) - ;; It's important that the RUN-TEST methods below all use DATA as the ;; TEST-DATA object name, because some of the macros defined at the ;; top of the file are hard coded to use the common names. @@ -271,3 +265,6 @@ ; :result-form '(values) ; :var-list '((cgi:*server-env* t))))) ; + +(defun run () + (mapcar #'run-test *cgi-tests*)) \ No newline at end of file

1 0

[clhp-cvs] CVS update: clhp/ChangeLog
by Anthony Ventimiglia 03 Oct '03

03 Oct '03

Update of /project/clhp/cvsroot/clhp In directory common-lisp.net:/tmp/cvs-serv4163 Modified Files: ChangeLog Log Message: (SIDE-EFFECT-FUNCTION-TEST-DATA): Test class for functions to test side effects that set globals. Still don't have it working right. Also improved the run-test methods by writing some macros, there's more work to do here as well. Date: Fri Oct 3 01:14:23 2003 Author: aventimiglia Index: clhp/ChangeLog diff -u clhp/ChangeLog:1.8 clhp/ChangeLog:1.9 --- clhp/ChangeLog:1.8 Thu Oct 2 22:40:39 2003 +++ clhp/ChangeLog Fri Oct 3 01:14:23 2003 @@ -1,3 +1,10 @@ +2003-10-03 <ant(a)afghan.dogpound> + + * tests/cgi-test.lisp (SIDE-EFFECT-FUNCTION-TEST-DATA): Test class + for functions to test side effects that set globals. Still don't + have it working right. Also improved the run-test methods by + writing some macros, there's more work to do here as well. + 2003-10-02 <ant(a)afghan.dogpound> * cgi.lisp, clhp.lisp (LIST-TO-A-LIST): Moved LIST-TO-A-LIST from @@ -47,4 +54,4 @@ used to create tables from (CONS . TYPE) a-lists. Also added some comments. -$Id: ChangeLog,v 1.8 2003/10/03 02:40:39 aventimiglia Exp $ \ No newline at end of file +$Id: ChangeLog,v 1.9 2003/10/03 05:14:23 aventimiglia Exp $ \ No newline at end of file

1 0

[clhp-cvs] CVS update: clhp/tests/cgi-test.lisp
by Anthony Ventimiglia 03 Oct '03

03 Oct '03

Update of /project/clhp/cvsroot/clhp/tests In directory common-lisp.net:/tmp/cvs-serv4163/tests Modified Files: cgi-test.lisp Log Message: (SIDE-EFFECT-FUNCTION-TEST-DATA): Test class for functions to test side effects that set globals. Still don't have it working right. Also improved the run-test methods by writing some macros, there's more work to do here as well. Date: Fri Oct 3 01:14:23 2003 Author: aventimiglia Index: clhp/tests/cgi-test.lisp diff -u clhp/tests/cgi-test.lisp:1.4 clhp/tests/cgi-test.lisp:1.5 --- clhp/tests/cgi-test.lisp:1.4 Thu Oct 2 22:40:39 2003 +++ clhp/tests/cgi-test.lisp Fri Oct 3 01:14:23 2003 @@ -29,14 +29,16 @@ (unless (find-package :cgi) (load "library:cgi"))) +;; These macros Used for run-test methods (defmacro call-if-function (form) `(when (functionp ,form) (funcall ,form))) -(defmacro test-result (result) - "Used to return results of tests for run-test methods" - ;; This will work as long as all RUN-TEST methods use DATA for their - ;; TEST-DATA object. - `(cons (test-data-symbol data) ,result)) +(defmacro test-return (test &rest args) + `(cons (test-data-symbol data) + (if ,test + (progn (princ 'ok stream) (terpri) :OK) + (progn (princ 'failed stream) (format stream ,@args) + (terpri) :FAILED)))) (defclass test-data () ((symbol :initform NIL @@ -57,11 +59,6 @@ (:documentation "Abstract supertype for CLASS, STRUCTURE, VARIABLE and FUNCTION test-data")) -(defmethod run-test ((data test-data) &optional stream) - "Since TEST-DATA is an abstract test class, we cannot actually use it." - (declare (ignore stream)) - (test-result :error)) - (defclass function-test-data (test-data) ((test-args :initform NIL :type list @@ -77,24 +74,6 @@ (:documentation "A class to test functions or macros, taking TEST-ARGS as a list of arguments to call the function with and expecting RESULT-FORM to be the result")) - -(defmethod run-test ((data function-test-data) - &optional (stream *standard-output*)) - (unwind-protect - (progn - (call-if-function (test-data-pre-function data)) - (let* ((test-form (cons (test-data-symbol data) - (function-test-data-test-args data))) - (result (eval test-form))) - (format stream "~S --> ~S : " test-form result) - (test-result - (let ((test-result (function-test-data-result-form data))) - (if (equal result test-result) - (progn - (format stream "OK~%") :OK) - (progn - (format stream "FAILED ~S expected~%" test-result) :error)))))) - (call-if-function (test-data-post-function data)))) (defclass output-function-test-data (function-test-data) ((output :initform NIL @@ -106,9 +85,44 @@ or functions, but this is used when thye output to *STANDARD-OUTPUT* must be tested as well.")) +(defclass side-effect-function-test-data (function-test-data) + ((var-list :initform NIL + :type list + :reader side-effect-function-test-data-var-list + :initarg :var-list + :documentation "An a-list of ((SYMBOL VALUE)) pairs. All +Symbols should be EQUAL to the VALUES after test function is +evaluated.")) + (:documentation "A subclass of function-test-data used to test +functions which have side effects of setting global variables.")) + + +(defmethod run-test ((data test-data) &optional stream) + "Since TEST-DATA is an abstract test class, we cannot actually use it." + (declare (ignore stream)) + (test-result :error)) + +;; It's important that the RUN-TEST methods below all use DATA as the +;; TEST-DATA object name, because some of the macros defined at the +;; top of the file are hard coded to use the common names. + + +(defmethod run-test ((data function-test-data) + &optional (stream *standard-output*)) + (unwind-protect + (progn + (call-if-function (test-data-pre-function data)) + (let* ((test-form (cons (test-data-symbol data) + (function-test-data-test-args data))) + (result (eval test-form))) + (format stream "~S --> ~S : " test-form result) + (let ((test-result (function-test-data-result-form data))) + (test-return (equal result test-result) + "~S expected" test-result)))) + (call-if-function (test-data-post-function data)))) + (defmethod run-test ((data output-function-test-data) &optional (stream *standard-output*)) - (call-if-function (test-data-pre-function data)) (unwind-protect (progn (call-if-function (test-data-pre-function data)) @@ -120,16 +134,34 @@ (*standard-output* output) (eval test-form)))) (format stream "~S --> ~S ~S : " test-form output result) - (test-result - (let ((test-output (output-function-test-data-output data)) - (test-result (function-test-data-result-form data))) - (if (and (equal result test-result) - (string= output test-output)) - (progn (format stream "OK~%") :OK) - (progn (format stream "FAILED ~S ~S expected~%" test-output - test-result) :ERROR)))))) + (let ((test-output (output-function-test-data-output data)) + (test-result (function-test-data-result-form data))) + (test-return (and (equal result test-result) + (string= output test-output)) + "~S -> ~S expected" test-output test-result)))) (call-if-function (test-data-post-function data)))) +(defmethod run-test ((data side-effect-function-test-data) + &optional stream) + (unwind-protect + (progn + (call-if-function (test-data-pre-function data)) + (let* ((test-form (cons (test-data-symbol data) + (function-test-data-test-args data))) + (result (eval test-form)) + (test-var-list (side-effect-function-test-data-var-list + data)) + (vars (mapcar #'(lambda (c) (car c)) test-var-list)) + (var-list (mapcar + #'(lambda (|v|) (list |v| (eval |v|))) vars))) + (format stream "~S --> ~S ~S : " + test-form result var-list) + (let ((test-result (output-function-test-data-output data))) + (test-return (and (equal result test-result) + (equal test-var-list var-list)) + "~S and ~S expected" test-result test-var-list)))) + (call-if-function (test-data-post-function data)))) + ;; Example ;(defvar list-test (make-instance 'function-test-data ; :symbol 'list @@ -138,14 +170,11 @@ ; ;* (run-test list-test) ;> (LIST 1 2 3 4 5) --> (1 2 3 4 5) : OK -;> (1 2 3 4 5) +;> (LIST . :OK ) (defvar *cgi-tests*) ;; Still to be tested -;; All functions which print to stdout, I'll have to devise a test for them: -;; DEBUG HEADER -;; ;; Functions which have side effects and no return values ;; INIT ;; @@ -192,6 +221,7 @@ (push (list :query_string "index=foo&type=bar%20baz") cgi:*server-env*)) + :post-function #'(lambda () (setq cgi:*server-env* nil)) :test-args nil :result-form '(#\i #\n #\d #\e #\x #\= #\f #\o #\o #\& #\t #\y #\p #\e #\= #\b #\a #\r #\% #\2 #\0 #\b @@ -225,4 +255,19 @@ (fmakunbound 'cgi:header) (load "library:cgi")) :symbol 'cgi:header - :output ""))) + :output "") + (make-instance 'function-test-data + :symbol 'cgi::ca-list-to-a-list + :test-args '('((a . 1)(b . 2)(c . 3))) + :result-form '((a 1)(b 2)(c 3))))) +; (make-instance 'side-effect-function-test-data +; :symbol 'cgi:init +; :pre-function #'(lambda () +; (setq ext:*environment-list* +; '((:request_method . "post") +; (:query_string . "hi=4&a=5")))) +; :post-function #'(lambda () +; (setq ext:*environment-list* "nil")) +; :result-form '(values) +; :var-list '((cgi:*server-env* t))))) +;

1 0

[clhp-cvs] CVS update: clhp/Makefile
by Anthony Ventimiglia 03 Oct '03

03 Oct '03

Update of /project/clhp/cvsroot/clhp In directory common-lisp.net:/tmp/cvs-serv8474 Modified Files: Makefile Log Message: Date: Thu Oct 2 22:44:30 2003 Author: aventimiglia Index: clhp/Makefile diff -u clhp/Makefile:1.8 clhp/Makefile:1.9 --- clhp/Makefile:1.8 Tue Sep 23 07:13:09 2003 +++ clhp/Makefile Thu Oct 2 22:44:30 2003 @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.8 2003/09/23 11:13:09 aventimiglia Exp $ +# $Id: Makefile,v 1.9 2003/10/03 02:44:30 aventimiglia Exp $ # # CLHP the Common Lisp Hypertext Preprocessor # (C) 2003 Anthony J Ventimiglia @@ -184,10 +184,10 @@ if test -f $$f ; then rm -v $$f ; fi \ done $(MAKE) -C examples clean + find -iname "*.tar.gz" -exec rm -v {} \; clean-backups: find -iname "*~" -exec rm -v {} \; clean-dist: if test -d $(TARROOT); then rm -rv $(TARROOT); fi - find -iname "*.tar.gz" -exec rm -v {} \;

1 0

[clhp-cvs] CVS update: clhp/clhp.lisp clhp/cgi.lisp clhp/ChangeLog
by Anthony Ventimiglia 03 Oct '03

03 Oct '03

Update of /project/clhp/cvsroot/clhp In directory common-lisp.net:/tmp/cvs-serv6192 Modified Files: clhp.lisp cgi.lisp ChangeLog Log Message: * cgi.lisp, clhp.lisp (LIST-TO-A-LIST): Moved LIST-TO-A-LIST from clhp.lisp into cgi.lisp, because I need it there as part of the rewrite for QUERY-TO-A-LIST. Sooner or later I'll have to merge all this into a single package so things like this do not have to happen. * cgi.lisp (QUERY-TO-A-LIST): Rewrote this mostly to simplify it, and make it prettier (*SERVER-ENV*,*QUERY-VARS*) : Converted them to list type a-lists ((A B)(C D)) from the Cons type they had been ((A . B) (C . D)). This is quite temporary, since I plan on making them hashes soon. I basically did this because the TAG mechanism needs List type a-lists, and I wanted to reuese list-to-a-list in cgi.lisp. So as part of the rewrite to QUERY-TO-A-LIST, this ended up as a result. Date: Thu Oct 2 22:40:39 2003 Author: aventimiglia Index: clhp/clhp.lisp diff -u clhp/clhp.lisp:1.9 clhp/clhp.lisp:1.10 --- clhp/clhp.lisp:1.9 Wed Oct 1 10:32:45 2003 +++ clhp/clhp.lisp Thu Oct 2 22:40:39 2003 @@ -1,5 +1,5 @@ (ext:file-comment - "$Id: clhp.lisp,v 1.9 2003/10/01 14:32:45 aventimiglia Exp $") + "$Id: clhp.lisp,v 1.10 2003/10/03 02:40:39 aventimiglia Exp $") ;; ;; CLHP the Common Lisp Hypertext Preprocessor ;; (C) 2003 Anthony J Ventimiglia @@ -38,7 +38,7 @@ ;; will override the CVS keyword (defconstant *CLHP-VERSION* #.(or nil ; Set this for releases - (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/10/01 14:32:45 $")) + (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/10/03 02:40:39 $")) (date (subseq trimmed 0 (search " " trimmed)))) (concatenate 'string (subseq date 0 4) @@ -185,19 +185,6 @@ contents name))) -(defun list-to-a-list (list &optional a-list) - "Converts a list to an a-list, pairing odd and even elements. If an -odd number of elements are in LIST, the last element is returnes as -the second value. -ex: (LIST-TO-A-LIST '(a b c d) --> '((a b)(c d)) NIL -ex: (LIST-TO-A-LIST '(1 2 3 4 5) --> '((1 2)(3 4)) 5" - (cond - ((null list) (nreverse a-list)) - ((= 1 (length list)) (values (nreverse a-list) (car list))) - (t (list-to-a-list (cddr list) - (cons (list (car list) (cadr list)) - a-list))))) - ;; This is a convenience function for MAKE-XML-ELEMENT (defun tag (&rest args) "Creates an XML-ELEMENT, where (CAR ARGS) fills the :NAME slot. If @@ -211,7 +198,7 @@ --> <IMG SRC=\"pic.png\"></IMG>" (multiple-value-bind (att-list contents) - (list-to-a-list (cdr args)) + (cgi::list-to-a-list (cdr args)) (make-xml-element :name (car args) :attributes att-list :contents contents))) Index: clhp/cgi.lisp diff -u clhp/cgi.lisp:1.5 clhp/cgi.lisp:1.6 --- clhp/cgi.lisp:1.5 Thu Oct 2 20:38:18 2003 +++ clhp/cgi.lisp Thu Oct 2 22:40:39 2003 @@ -1,4 +1,4 @@ -#+cmu (ext:file-comment "$Id: cgi.lisp,v 1.5 2003/10/03 00:38:18 aventimiglia Exp $") +#+cmu (ext:file-comment "$Id: cgi.lisp,v 1.6 2003/10/03 02:40:39 aventimiglia Exp $") ;; ;; CLHP the Common Lisp Hypertext Preprocessor ;; (C) 2003 Anthony J Ventimiglia @@ -43,7 +43,7 @@ (defmacro a-list-value (key a-list) "returns the value from a (KEY . VALUE) A-LIST" - `(cdr (assoc ,key ,a-list))) + `(cadr (assoc ,key ,a-list))) ;; External Symbol section @@ -65,8 +65,7 @@ ;; is set up so it will only work the first time it is called, any ;; furthur calls will not do a thing (let ((done nil)) - (defun header (&key (content-type 'text/plain) - extra) + (defun header (&key (content-type 'text/plain) extra) "This is the first output function that should be called by a CGI program, it print the proper CGI header. The :CONTENT-TYPE field can be a symbol, or a string, if whitespace is required. @@ -83,13 +82,17 @@ (format t "Content-type: ~a~%~%" content-type) (setf done t)))) +(defun ca-list-to-a-list (list) + "Converts a CONS type a-list '((A . 3)(B . 4)) to a list type '((A 3)(B 4))" + (mapcar #'(lambda (cons) (list (car cons)(cdr cons))) list)) + ;; This sets the main variables, since the library is already part of the lisp ;; core, we can't use an eval-when, I may eventually make a cgi:init that also ;; prints the header. (defun init () "Initialize CGI, this should be called before any globals are accessed" - (setf *server-env* ext:*environment-list* + (setf *server-env* (ca-list-to-a-list ext:*environment-list*) *query-vars* (let ((request-method (make-keyword (a-list-value :REQUEST_METHOD @@ -168,16 +171,25 @@ post-char-list) post-char-list))) +(defun list-to-a-list (list &optional a-list) + "Converts a list to an a-list, pairing odd and even elements. If an +odd number of elements are in LIST, the last element is returnes as +the second value. +ex: (LIST-TO-A-LIST '(a b c d) --> '((a b)(c d)) NIL +ex: (LIST-TO-A-LIST '(1 2 3 4 5) --> '((1 2)(3 4)) 5" + (cond + ((null list) (nreverse a-list)) + ((= 1 (length list)) (values (nreverse a-list) (car list))) + (t (list-to-a-list (cddr list) + (cons (list (car list) (cadr list)) + a-list))))) + (defun query-to-a-list (get/post-data) - "Translates the char list from GET-DATA or POST-DATA into a (:KEYWORD -. \"Value\" ) a-list." - (mapcar #'(lambda (key/val-list) - (let ((key/val-strings - (mapcar #'implode-string - (split-char-list #\= key/val-list)))) - (cons (make-keyword (car key/val-strings)) - (cadr key/val-strings)))) - (split-char-list #\& (url-decode-char-list get/post-data)))) + (list-to-a-list + (mapcar #'implode-string + (mapcan #'(lambda (c) (split-char-list #\= c)) + (split-char-list + #\& (url-decode-char-list get/post-data)))))) (defun url-decode-char-list (char-list) "Decodes encoded URL chars as per RFC 1738" Index: clhp/ChangeLog diff -u clhp/ChangeLog:1.7 clhp/ChangeLog:1.8 --- clhp/ChangeLog:1.7 Thu Oct 2 20:38:18 2003 +++ clhp/ChangeLog Thu Oct 2 22:40:39 2003 @@ -1,11 +1,27 @@ 2003-10-02 <ant(a)afghan.dogpound> - * tests/cgi-test.lisp (output-function-test-data): Designed a - class to test functions which print to *standard-output*. These + * cgi.lisp, clhp.lisp (LIST-TO-A-LIST): Moved LIST-TO-A-LIST from + clhp.lisp into cgi.lisp, because I need it there as part of the + rewrite for QUERY-TO-A-LIST. Sooner or later I'll have to merge + all this into a single package so things like this do not have to + happen. + + * cgi.lisp (QUERY-TO-A-LIST): Rewrote this mostly to + simplify it, and make it prettier + (*SERVER-ENV*,*QUERY-VARS*) : Converted them to list type a-lists + ((A B)(C D)) from the Cons type they had been ((A . B) (C + . D)). This is quite temporary, since I plan on making them hashes + soon. I basically did this because the TAG mechanism needs List + type a-lists, and I wanted to reuese list-to-a-list in + cgi.lisp. So as part of the rewrite to QUERY-TO-A-LIST, this ended + up as a result. + + * tests/cgi-test.lisp (OUTPUT-FUNCTION-TEST-DATA): Designed a + class to test functions which print to *STANDARD-OUTPUT*. These test classes will be reused for clhp.lisp, and eventually moved into their own package. - * cgi.lisp (a-list-value): Convenience macro for getting the + * cgi.lisp (A-LIST-VALUE): Convenience macro for getting the values of a-lists 2003-10-01 <ant(a)afghan.dogpound> @@ -23,7 +39,7 @@ PPRINT-XML-ELEMENT, which outputs the structure as an xml tag. I also wrote TAG, which is a convenience function that makes xml-element creation a breeze. - (evaluate-code-block): Enhanced error handling facility, now + (EVALUATE-CODE-BLOCK): Enhanced error handling facility, now errors are reported and processing continues. * examples/index.clhp: Placed some examples of using TAG @@ -31,4 +47,4 @@ used to create tables from (CONS . TYPE) a-lists. Also added some comments. - +$Id: ChangeLog,v 1.8 2003/10/03 02:40:39 aventimiglia Exp $ \ No newline at end of file

1 0

[clhp-cvs] CVS update: clhp/tests/cgi-test.lisp
by Anthony Ventimiglia 03 Oct '03

03 Oct '03

Update of /project/clhp/cvsroot/clhp/tests In directory common-lisp.net:/tmp/cvs-serv6192/tests Modified Files: cgi-test.lisp Log Message: * cgi.lisp, clhp.lisp (LIST-TO-A-LIST): Moved LIST-TO-A-LIST from clhp.lisp into cgi.lisp, because I need it there as part of the rewrite for QUERY-TO-A-LIST. Sooner or later I'll have to merge all this into a single package so things like this do not have to happen. * cgi.lisp (QUERY-TO-A-LIST): Rewrote this mostly to simplify it, and make it prettier (*SERVER-ENV*,*QUERY-VARS*) : Converted them to list type a-lists ((A B)(C D)) from the Cons type they had been ((A . B) (C . D)). This is quite temporary, since I plan on making them hashes soon. I basically did this because the TAG mechanism needs List type a-lists, and I wanted to reuese list-to-a-list in cgi.lisp. So as part of the rewrite to QUERY-TO-A-LIST, this ended up as a result. Date: Thu Oct 2 22:40:39 2003 Author: aventimiglia Index: clhp/tests/cgi-test.lisp diff -u clhp/tests/cgi-test.lisp:1.3 clhp/tests/cgi-test.lisp:1.4 --- clhp/tests/cgi-test.lisp:1.3 Thu Oct 2 20:38:17 2003 +++ clhp/tests/cgi-test.lisp Thu Oct 2 22:40:39 2003 @@ -184,21 +184,21 @@ (make-instance 'function-test-data :symbol 'cgi::get-data :pre-function #'(lambda () - (let ((a (assoc :query_string - cgi::*server-env*))) + (let ((a (car (assoc :query_string + cgi::*server-env*)))) (when a - (setf cgi::*server-env* - (remove a cgi::*server-env*)))) - (push (cons :query_string + (setf cgi:*server-env* + (remove a cgi:*server-env*)))) + (push (list :query_string "index=foo&type=bar%20baz") - cgi::*server-env*)) + cgi:*server-env*)) :test-args nil :result-form '(#\i #\n #\d #\e #\x #\= #\f #\o #\o #\& #\t #\y #\p #\e #\= #\b #\a #\r #\% #\2 #\0 #\b #\a #\z)) (make-instance 'function-test-data :symbol 'cgi::a-list-value - :test-args '(2 '((1 . f) (3 . g) (6 . h) (2 . y))) + :test-args '(2 '((1 f) (3 g) (6 h) (2 y))) :result-form 'y) (make-instance 'output-function-test-data :symbol 'cgi:debug

1 0