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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide annotations)
Fri Nov 14 22:32:10 2003 UTC (10 years, 5 months ago) by aventimiglia
Branch: MAIN
CVS Tags: rel-0-2-1alpha
Changes since 1.21: +3 -3 lines
Changes for 0.2.1alpha release
1 aventimiglia 1.1 (ext:file-comment
2 aventimiglia 1.22 "$Id: clhp.lisp,v 1.22 2003/11/14 22:32:10 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.22 #.(or "0.2.1alpha" ; Set this for releases
32     (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/11/14 22:32:10 $"))
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 aventimiglia 1.1 ;; We'll read the whole thing here into a buffer, then send it to
76     ;; PARSE-BUFFER to recursively process it
77     (handler-bind
78     ((error #'handle-error))
79     (with-open-file
80     (stream file-name :direction :input :if-does-not-exist :error)
81     ;; FILE-LENGTH could return NIL, I don't see why, but nevertheless
82     ;; I will have to write an error checking macro around it to
83     ;; signal an error if file-length can't be determined.
84     (let* ((buffer-size (file-length stream))
85     (buffer (make-array buffer-size :element-type 'character)))
86     ;; Should also check for anything fishy like a read that does not
87     ;; match FILE-SIZE
88     (read-sequence buffer stream)
89     (parse-buffer buffer :end buffer-size)))))
90    
91    
92     (defun parse-buffer (buffer &key (start 0) end (code-block nil) (in-block nil))
93     "Takes blocks of text passed from PARSE, evaluates anything inside
94 aventimiglia 1.7 the <?clhp ?> elements, and dumps the rest through unscathed."
95 aventimiglia 1.1 (declare (type (array character 1) buffer)
96     (type fixnum end))
97 aventimiglia 1.11 (cond-bind ((index (if in-block
98     (find-pi-end buffer :start start :end end)
99     (find-pi-start buffer :start start :end end))))
100 aventimiglia 1.1 ((>= start end) ; Done with this buffer
101     nil)
102     ((and in-block index) ; Found the end of a code-block
103     (evaluate-code-block
104     (append code-block (coerce (subseq buffer start index) 'list)))
105     (parse-buffer buffer
106     :start (+ index #.(length *PI-END*))
107     :end end))
108     ((and (not in-block) index) ; Found code-block start
109     (write-sequence buffer *standard-output* :start start :end index)
110     (parse-buffer buffer
111     :start (+ index #.(length *PI-START*))
112     :end end
113     :in-block t))
114     (in-block (signal 'parse-error))
115     (t ; Not in code-block no start in sight
116 aventimiglia 1.11 (write-sequence buffer *standard-output* :start start :end end))))
117 aventimiglia 1.1
118     (defun evaluate-code-block (code-block)
119     "Read the Lisp object represented by CODE-BLOCK, and evaluate it."
120     (declare (type list code-block))
121 aventimiglia 1.8 (let ((form nil)
122     (index 0)
123     (eof (gensym)))
124     (loop
125     (handler-case
126     (progn
127     (multiple-value-setq
128     (form index)
129     (read-from-string (coerce code-block 'string)
130     nil eof :start index))
131     (when (eq eof form) (return))
132     (eval form))
133     (condition (c)
134     (echo
135     (tag "p"
136     (tag "i"
137     (list
138     (format nil "~&CLHP: ~A in the form ~A : "
139     (type-of c) form)
140     (report-error-string c)))))
141     (when (typep c 'end-of-file) (return)))))))
142    
143    
144 aventimiglia 1.1
145     (defun echo (string &rest more)
146 aventimiglia 1.7 "This allows long strings or lisp objects to be broken up into
147     separate lines as separate strings, all the strings passed will be
148     concatenated and printed to *STANDARD-OUTPUT*. It is analogous to the
149     way string constants are all concatenated by the C++ compiler, or the
150     way strings can be concatenated with the '.' operator in PHP. There is
151     no method for newlines, use the standars TERPRI or FRESH-LINE
152     functions."
153 aventimiglia 1.1 (dolist (chunk (cons string more)) (princ chunk)))
154    
155 aventimiglia 1.7 (defun pprint-xml-element (xml-element stream depth)
156     (declare (ignore depth))
157     (let ((name (xml-element-name xml-element))
158     (contents (xml-element-contents xml-element)))
159     (format stream "<~A~:{ ~A=\"~A\"~}>~:[~A~;~{~A~}~]</~A>"
160     name
161     (xml-element-attributes xml-element)
162     (listp contents)
163     contents
164     name)))
165    
166     ;; This is a convenience function for MAKE-XML-ELEMENT
167     (defun tag (&rest args)
168     "Creates an XML-ELEMENT, where (CAR ARGS) fills the :NAME slot. If
169     ARGS has an even number of elements, then (CDR (BUTLAST ARGS)) is
170     converted to an a-list to fill the :ATTRIBUTES slot, and (CAR (LAST
171     ARGS)) fills :CONTENTS, otherwise (CDR ARGS) is converted to an a-list
172     for :ATTRIBUTES, and :CONTENTS is NIL
173     ex: (tag 'A 'HREF \"http://bogus.com/\" \"Simple Link\")
174     --> <A HREF=\"http://bogus.com/\">Simple Link</A>
175     (tag 'img 'src \"pic.png\")
176     --> <IMG SRC=\"pic.png\"></IMG>"
177     (multiple-value-bind
178     (att-list contents)
179 aventimiglia 1.11 (list-to-a-list (cdr args))
180 aventimiglia 1.7 (make-xml-element :name (car args)
181     :attributes att-list
182     :contents contents)))
183 aventimiglia 1.18
184     ;; Similar to PHP's require, loads a lisp file in the local directory.
185     (defun require (filename)
186     "Load the lisp source or fasl file FILENAME, relative to the document root"
187     (let ((doc-root
188     (make-pathname :name nil :type nil :version nil
189     :defaults (parse-namestring
190     (gethash :script_filename *server-env*)))))
191     (load (merge-pathnames doc-root filename))))
192 aventimiglia 1.1
193     ;; Error handling is probably the biggest room to work here. I should
194     ;; eventually make a handler that binds the evaluation of clhp PI
195     ;; embedded code, that handler could then relay the entire block of
196     ;; code in its error reporting.
197     (defun handle-error (condition)
198     "Top level generic error"
199     (let ((error-type (type-of condition)))
200 aventimiglia 1.8 (format t "Error: ~a : ~a"
201     error-type (report-error-string condition))))
202 aventimiglia 1.7
203 aventimiglia 1.8 (defun report-error-string (condition)
204     "Given a condition, returns a string describing the error. This is
205     used by the error-handler in EVALUATE-CODE-BLOCK and HANDLE-ERROR."
206     (format nil "~A"
207     (case (type-of condition)
208     ((or unbound-variable undefined-function)
209     (cell-error-name condition))
210     (end-of-file
211     (stream-error-stream condition))
212     (kernel:simple-file-error
213     (file-error-pathname condition))
214     (otherwise
215     "Add a handler in REPORT-ERROR-STRING for this condition"))))

  ViewVC Help
Powered by ViewVC 1.1.5