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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5