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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5