/[clhp]/clhp/clhp.lisp
ViewVC logotype

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Thu Oct 16 16:57:25 2003 UTC (10 years, 6 months ago) by aventimiglia
Branch: MAIN
Changes since 1.13: +5 -5 lines
* tests/clhp-test.lisp (*CLHP-TESTS*): Wrote tests for most of
:CLHP

* clhp.lisp (FIND-PI-START, FIND-PI-END): Made 0 a default value
for START.
1 aventimiglia 1.1 (ext:file-comment
2 aventimiglia 1.14 "$Id: clhp.lisp,v 1.14 2003/10/16 16:57:25 aventimiglia Exp $")
3 aventimiglia 1.1 ;;
4     ;; CLHP the Common Lisp Hypertext Preprocessor
5     ;; (C) 2003 Anthony J Ventimiglia
6     ;;
7     ;; This library is free software; you can redistribute it and/or
8     ;; modify it under the terms of the GNU Lesser General Public
9     ;; License as published by the Free Software Foundation; either
10     ;; version 2.1 of the License, or (at your option) any later version.
11     ;;
12     ;; This library is distributed in the hope that it will be useful,
13     ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15     ;; Lesser General Public License for more details.
16     ;;
17     ;; You should have received a copy of the GNU Lesser General Public
18     ;; License along with this library; if not, write to the Free Software
19     ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20     ;;
21 aventimiglia 1.12 ;; email: aventimiglia@common-lisp.net
22 aventimiglia 1.1 ;; HomePage: http://common-lisp.net/project/clhp/
23    
24     (eval-when (:compile-toplevel)
25     (unless (find-package :cgi)
26     (load "cgi")))
27    
28 aventimiglia 1.13 (defpackage #:net.common-lisp.aventimiglia.clhp
29     (:nicknames :clhp)
30 aventimiglia 1.9 (:use :cgi :cl)
31 aventimiglia 1.11 (:import-from :cgi #:cond-bind #:list-to-a-list)
32 aventimiglia 1.9 (:export #:parse #:*clhp-version* #:echo #:include #:xml-element
33     #:make-xml-element #:copy-xml-element #:xml-element-attributes
34     #:xml-element-name #:xml-element-contents #:xml-element-p #:tag))
35     (in-package :clhp)
36 aventimiglia 1.1
37 aventimiglia 1.2 ;; This elaborate reader macro converts the cvs Date keywords and
38     ;; translates it into a 8 digit date code for marking the cvs version.
39     ;; by changing the NIL in the first part of the OR, a release number
40     ;; will override the CVS keyword
41     (defconstant *CLHP-VERSION*
42 aventimiglia 1.13 #.(or "0.1.1alpha" ; Set this for releases
43 aventimiglia 1.14 (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/10/16 16:57:25 $"))
44 aventimiglia 1.2 (date (subseq trimmed 0 (search " " trimmed))))
45     (concatenate 'string
46     (subseq date 0 4)
47     (subseq date 5 7)
48 aventimiglia 1.3 (subseq date 8 10)
49     "cvs"))))
50 aventimiglia 1.1 (defconstant *PI-START* "<?clhp")
51     (defconstant *PI-END* "?>")
52    
53 aventimiglia 1.7 ;; The Xml-Element Structure, with its print function makes generation and
54     ;; printing of generic XML elements quite lovely
55     (defstruct (xml-element (:print-function pprint-xml-element))
56     "An XML element structure. NAME can be a symbol or string and
57     reflects the element name. ATTRIBUTES is an a-list of (NAME VALUE)
58     pairs corresponding to the elements Attributes. CONTENTS should
59     eveluate to a string, symbol, tag or list of strings, symbols or tags,
60     which may be mixed. Using the PPRINT-XML-ELEMENT function, these tags are
61     printed as they will appear."
62     (name NIL :type (or symbol string) :read-only t)
63     (attributes NIL :type list)
64     (contents NIL :type (or string symbol cons xml-element)))
65    
66 aventimiglia 1.14 (defmacro find-pi-start (buffer &key (start 0) end)
67 aventimiglia 1.1 "Find the next occurence of *PI-START* and return its index. Returns
68     NIL if not found"
69     (declare (type (array character 1) buffer)
70 aventimiglia 1.14 (type fixnum start))
71 aventimiglia 1.1 `(search ,*PI-START* ,buffer :test #'string= :start2 ,start :end2 ,end))
72    
73 aventimiglia 1.14 (defmacro find-pi-end (buffer &key (start 0) end)
74 aventimiglia 1.1 (declare (type (array character 1) buffer)
75     (type fixnum start end))
76     "Find the next occurence of *pi-end* and return its index. Returns
77     NIL if not found."
78     `(search ,*PI-END* ,buffer :test #'string= :start2 ,start :end2 ,end))
79    
80     (defun parse (file-name)
81     "This is the only thing that needs to be called from a CL-CGI script
82     to use CLHP. See README for an example."
83     (use-package :cgi)
84     (use-package :clhp)
85     (cgi:init)
86     (cgi:header :content-type
87     :text/html
88     :extra
89     '(#.(format
90     nil
91     "X-Powered-By: CLHP/~a Common Lisp Hypertext Preprocessor"
92     *CLHP-VERSION*)))
93     (include file-name))
94    
95     (defun include (file-name)
96 aventimiglia 1.7 "parse FILE-NAME as a CLHP file, this is essentially the same as
97     PARSE, only it does not output headers."
98 aventimiglia 1.1 ;; We'll read the whole thing here into a buffer, then send it to
99     ;; PARSE-BUFFER to recursively process it
100     (handler-bind
101     ((error #'handle-error))
102     (with-open-file
103     (stream file-name :direction :input :if-does-not-exist :error)
104     ;; FILE-LENGTH could return NIL, I don't see why, but nevertheless
105     ;; I will have to write an error checking macro around it to
106     ;; signal an error if file-length can't be determined.
107     (let* ((buffer-size (file-length stream))
108     (buffer (make-array buffer-size :element-type 'character)))
109     ;; Should also check for anything fishy like a read that does not
110     ;; match FILE-SIZE
111     (read-sequence buffer stream)
112     (parse-buffer buffer :end buffer-size)))))
113    
114    
115     (defun parse-buffer (buffer &key (start 0) end (code-block nil) (in-block nil))
116     "Takes blocks of text passed from PARSE, evaluates anything inside
117 aventimiglia 1.7 the <?clhp ?> elements, and dumps the rest through unscathed."
118 aventimiglia 1.1 (declare (type (array character 1) buffer)
119     (type fixnum end))
120 aventimiglia 1.11 (cond-bind ((index (if in-block
121     (find-pi-end buffer :start start :end end)
122     (find-pi-start buffer :start start :end end))))
123 aventimiglia 1.1 ((>= start end) ; Done with this buffer
124     nil)
125     ((and in-block index) ; Found the end of a code-block
126     (evaluate-code-block
127     (append code-block (coerce (subseq buffer start index) 'list)))
128     (parse-buffer buffer
129     :start (+ index #.(length *PI-END*))
130     :end end))
131     ((and (not in-block) index) ; Found code-block start
132     (write-sequence buffer *standard-output* :start start :end index)
133     (parse-buffer buffer
134     :start (+ index #.(length *PI-START*))
135     :end end
136     :in-block t))
137     (in-block (signal 'parse-error))
138     (t ; Not in code-block no start in sight
139 aventimiglia 1.11 (write-sequence buffer *standard-output* :start start :end end))))
140 aventimiglia 1.1
141     (defun evaluate-code-block (code-block)
142     "Read the Lisp object represented by CODE-BLOCK, and evaluate it."
143     (declare (type list code-block))
144 aventimiglia 1.8 (let ((form nil)
145     (index 0)
146     (eof (gensym)))
147     (loop
148     (handler-case
149     (progn
150     (multiple-value-setq
151     (form index)
152     (read-from-string (coerce code-block 'string)
153     nil eof :start index))
154     (when (eq eof form) (return))
155     (eval form))
156     (condition (c)
157     (echo
158     (tag "p"
159     (tag "i"
160     (list
161     (format nil "~&CLHP: ~A in the form ~A : "
162     (type-of c) form)
163     (report-error-string c)))))
164     (when (typep c 'end-of-file) (return)))))))
165    
166    
167 aventimiglia 1.1
168     (defun echo (string &rest more)
169 aventimiglia 1.7 "This allows long strings or lisp objects to be broken up into
170     separate lines as separate strings, all the strings passed will be
171     concatenated and printed to *STANDARD-OUTPUT*. It is analogous to the
172     way string constants are all concatenated by the C++ compiler, or the
173     way strings can be concatenated with the '.' operator in PHP. There is
174     no method for newlines, use the standars TERPRI or FRESH-LINE
175     functions."
176 aventimiglia 1.1 (dolist (chunk (cons string more)) (princ chunk)))
177    
178 aventimiglia 1.7 (defun pprint-xml-element (xml-element stream depth)
179     (declare (ignore depth))
180     (let ((name (xml-element-name xml-element))
181     (contents (xml-element-contents xml-element)))
182     (format stream "<~A~:{ ~A=\"~A\"~}>~:[~A~;~{~A~}~]</~A>"
183     name
184     (xml-element-attributes xml-element)
185     (listp contents)
186     contents
187     name)))
188    
189     ;; This is a convenience function for MAKE-XML-ELEMENT
190     (defun tag (&rest args)
191     "Creates an XML-ELEMENT, where (CAR ARGS) fills the :NAME slot. If
192     ARGS has an even number of elements, then (CDR (BUTLAST ARGS)) is
193     converted to an a-list to fill the :ATTRIBUTES slot, and (CAR (LAST
194     ARGS)) fills :CONTENTS, otherwise (CDR ARGS) is converted to an a-list
195     for :ATTRIBUTES, and :CONTENTS is NIL
196     ex: (tag 'A 'HREF \"http://bogus.com/\" \"Simple Link\")
197     --> <A HREF=\"http://bogus.com/\">Simple Link</A>
198     (tag 'img 'src \"pic.png\")
199     --> <IMG SRC=\"pic.png\"></IMG>"
200     (multiple-value-bind
201     (att-list contents)
202 aventimiglia 1.11 (list-to-a-list (cdr args))
203 aventimiglia 1.7 (make-xml-element :name (car args)
204     :attributes att-list
205     :contents contents)))
206 aventimiglia 1.1
207     ;; Error handling is probably the biggest room to work here. I should
208     ;; eventually make a handler that binds the evaluation of clhp PI
209     ;; embedded code, that handler could then relay the entire block of
210     ;; code in its error reporting.
211     (defun handle-error (condition)
212     "Top level generic error"
213     (let ((error-type (type-of condition)))
214 aventimiglia 1.8 (format t "Error: ~a : ~a"
215     error-type (report-error-string condition))))
216 aventimiglia 1.7
217 aventimiglia 1.8 (defun report-error-string (condition)
218     "Given a condition, returns a string describing the error. This is
219     used by the error-handler in EVALUATE-CODE-BLOCK and HANDLE-ERROR."
220     (format nil "~A"
221     (case (type-of condition)
222     ((or unbound-variable undefined-function)
223     (cell-error-name condition))
224     (end-of-file
225     (stream-error-stream condition))
226     (kernel:simple-file-error
227     (file-error-pathname condition))
228     (otherwise
229     "Add a handler in REPORT-ERROR-STRING for this condition"))))

  ViewVC Help
Powered by ViewVC 1.1.5