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

Contents of /clhp/clhp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide 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 aventimiglia 1.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