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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Thu Oct 16 19:31:59 2003 UTC (10 years, 6 months ago) by aventimiglia
Branch: MAIN
Changes since 1.14: +3 -3 lines
Trying to get a nice little feature where the makefile creates a CVS
version ID similar to how it's done in clhp.lisp
1 (ext:file-comment
2 "$Id: clhp.lisp,v 1.15 2003/10/16 19:31:59 aventimiglia Exp $")
3 ;;
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 ;; email: aventimiglia@common-lisp.net
22 ;; HomePage: http://common-lisp.net/project/clhp/
23
24 (eval-when (:compile-toplevel)
25 (unless (find-package :cgi)
26 (load "cgi")))
27
28 (defpackage #:net.common-lisp.aventimiglia.clhp
29 (:nicknames :clhp)
30 (:use :cgi :cl)
31 (:import-from :cgi #:cond-bind #:list-to-a-list)
32 (: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
37 ;; 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 #.(or nil ; Set this for releases
43 (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/10/16 19:31:59 $"))
44 (date (subseq trimmed 0 (search " " trimmed))))
45 (concatenate 'string
46 (subseq date 0 4)
47 (subseq date 5 7)
48 (subseq date 8 10)
49 "cvs"))))
50 (defconstant *PI-START* "<?clhp")
51 (defconstant *PI-END* "?>")
52
53 ;; 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 (defmacro find-pi-start (buffer &key (start 0) end)
67 "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 (type fixnum start))
71 `(search ,*PI-START* ,buffer :test #'string= :start2 ,start :end2 ,end))
72
73 (defmacro find-pi-end (buffer &key (start 0) end)
74 (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 "parse FILE-NAME as a CLHP file, this is essentially the same as
97 PARSE, only it does not output headers."
98 ;; 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 the <?clhp ?> elements, and dumps the rest through unscathed."
118 (declare (type (array character 1) buffer)
119 (type fixnum end))
120 (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 ((>= 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 (write-sequence buffer *standard-output* :start start :end end))))
140
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 (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
168 (defun echo (string &rest more)
169 "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 (dolist (chunk (cons string more)) (princ chunk)))
177
178 (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 (list-to-a-list (cdr args))
203 (make-xml-element :name (car args)
204 :attributes att-list
205 :contents contents)))
206
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 (format t "Error: ~a : ~a"
215 error-type (report-error-string condition))))
216
217 (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