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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5