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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Wed Sep 17 20:21:52 2003 UTC (10 years, 7 months ago) by aventimiglia
Branch: MAIN
Changes since 1.2: +5 -4 lines
Wrote a nice little reader macro to make cvs versioning automatic, the
$Date$ keyword is parsed to make a 8 digit number YYYYMMDD with the
suffix "cvs" addedd, so a CVS release with a $Date$ of 2003/09/15 ends
up with a *CLHP-VERSION* of "20030915cvs"
1 (ext:file-comment
2 "$Id: clhp.lisp,v 1.3 2003/09/17 20:21:52 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: aventimigli@common-lisp.net
22 ;; HomePage: http://common-lisp.net/project/clhp/
23
24 ;; This is here to make clean compilation
25 (eval-when (:compile-toplevel)
26 (when (find-package :clhp)
27 (delete-package :clhp))
28 ;; Since CGU us used and we may be building this before it's installed,
29 ;; We'll need to load it.
30 (unless (find-package :cgi)
31 (load "cgi")))
32
33 (make-package :CLHP)
34
35 (in-package :CLHP)
36 (export '(PARSE *CLHP-VERSION* ECHO TAG INCLUDE))
37
38 ;; This elaborate reader macro converts the cvs Date keywords and
39 ;; translates it into a 8 digit date code for marking the cvs version.
40 ;; by changing the NIL in the first part of the OR, a release number
41 ;; will override the CVS keyword
42 (defconstant *CLHP-VERSION*
43 #.(or nil ; Set this for releases
44 (let* ((trimmed (string-trim "$ Date:" "$Date: 2003/09/17 20:21:52 $"))
45 (date (subseq trimmed 0 (search " " trimmed))))
46 (concatenate 'string
47 (subseq date 0 4)
48 (subseq date 5 7)
49 (subseq date 8 10)
50 "cvs"))))
51 (defconstant *PI-START* "<?clhp")
52 (defconstant *PI-END* "?>")
53
54 (defmacro find-pi-start (buffer &key start end)
55 "Find the next occurence of *PI-START* and return its index. Returns
56 NIL if not found"
57 (declare (type (array character 1) buffer)
58 (type fixnum start end))
59 `(search ,*PI-START* ,buffer :test #'string= :start2 ,start :end2 ,end))
60
61 (defmacro find-pi-end (buffer &key start end)
62 (declare (type (array character 1) buffer)
63 (type fixnum start end))
64 "Find the next occurence of *pi-end* and return its index. Returns
65 NIL if not found."
66 `(search ,*PI-END* ,buffer :test #'string= :start2 ,start :end2 ,end))
67
68 (defun parse (file-name)
69 "This is the only thing that needs to be called from a CL-CGI script
70 to use CLHP. See README for an example."
71 (use-package :cgi)
72 (use-package :clhp)
73 (cgi:init)
74 (cgi:header :content-type
75 :text/html
76 :extra
77 '(#.(format
78 nil
79 "X-Powered-By: CLHP/~a Common Lisp Hypertext Preprocessor"
80 *CLHP-VERSION*)))
81 (include file-name))
82
83 (defun include (file-name)
84 "parse FILE-NAME as a CLHP file, this is essentially the same as PARSE, only it does not output headers."
85 ;; We'll read the whole thing here into a buffer, then send it to
86 ;; PARSE-BUFFER to recursively process it
87 (handler-bind
88 ((error #'handle-error))
89 (with-open-file
90 (stream file-name :direction :input :if-does-not-exist :error)
91 ;; FILE-LENGTH could return NIL, I don't see why, but nevertheless
92 ;; I will have to write an error checking macro around it to
93 ;; signal an error if file-length can't be determined.
94 (let* ((buffer-size (file-length stream))
95 (buffer (make-array buffer-size :element-type 'character)))
96 ;; Should also check for anything fishy like a read that does not
97 ;; match FILE-SIZE
98 (read-sequence buffer stream)
99 (parse-buffer buffer :end buffer-size)))))
100
101
102 (defun parse-buffer (buffer &key (start 0) end (code-block nil) (in-block nil))
103 "Takes blocks of text passed from PARSE, evaluates anything inside
104 the <?clhp ?> tags, and dumps the rest through unscathed."
105 (declare (type (array character 1) buffer)
106 (type fixnum end))
107 (let ((index (if in-block
108 (find-pi-end buffer :start start :end end)
109 (find-pi-start buffer :start start :end end))))
110 (cond
111 ((>= start end) ; Done with this buffer
112 nil)
113 ((and in-block index) ; Found the end of a code-block
114 (evaluate-code-block
115 (append code-block (coerce (subseq buffer start index) 'list)))
116 (parse-buffer buffer
117 :start (+ index #.(length *PI-END*))
118 :end end))
119 ((and (not in-block) index) ; Found code-block start
120 (write-sequence buffer *standard-output* :start start :end index)
121 (parse-buffer buffer
122 :start (+ index #.(length *PI-START*))
123 :end end
124 :in-block t))
125 (in-block (signal 'parse-error))
126 (t ; Not in code-block no start in sight
127 (write-sequence buffer *standard-output* :start start :end end)))))
128
129 (defun evaluate-code-block (code-block)
130 "Read the Lisp object represented by CODE-BLOCK, and evaluate it."
131 (declare (type list code-block))
132 (eval (read-from-string
133 (concatenate 'string
134 "(progn "
135 (coerce code-block 'string)
136 ")"))))
137
138 (defun echo (string &rest more)
139 "This allows long strings to be broken up into separate lines as
140 separate strings, all the strings passed will be concatenated and
141 printed to *STANDARD-OUTPUT*. It is analogous to the way string
142 constants are all concatenated by the C++ compiler, or the way strings
143 can be concatenated with the '.' operator in PHP. There is no method
144 for newlines, use the standars TERPRI or FRESH-LINE functions."
145 (dolist (chunk (cons string more)) (princ chunk)))
146
147 ;; This needs work, it will probably need to be redone as a macro
148 (defun tag (name &optional attributes contents)
149 "Creates an XML tag named NAME, ATTRIBUTES is an a-list and the
150 forms in CONTENTS are evaluated as an implicit PROGN."
151 (format t "<~a~:{ ~a=\"~a\"~}>~%" name attributes)
152 (eval (cons 'progn contents))
153 (format t "</~a>~%" name))
154
155 ;; Error handling is probably the biggest room to work here. I should
156 ;; eventually make a handler that binds the evaluation of clhp PI
157 ;; embedded code, that handler could then relay the entire block of
158 ;; code in its error reporting.
159 (defun handle-error (condition)
160 "Top level generic error"
161 (let ((error-type (type-of condition)))
162 (format t "Error: ~a" error-type)
163 (case error-type
164 ((or unbound-variable undefined-function)
165 (format t ": ~a~%" (cell-error-name condition)))
166 (end-of-file
167 (format t ": stream ~a~%" (stream-error-stream condition)))
168 (kernel:simple-file-error
169 (format t ": ~a~%" (file-error-pathname condition)))
170 ; I saw a compiler error once, then I put this here and it stopped.
171 ; Go Figure -- so this hasn't been tested
172 (compiler-error
173 (format t ": ~a~%" (c::compiler-error-message condition)))
174 (otherwise
175 (format t ": Please report this poor error reporting.~%")))))
176
177

  ViewVC Help
Powered by ViewVC 1.1.5