source: project/release/4/spiffy/trunk/ssp-handler.scm @ 12519

Last change on this file since 12519 was 12519, checked in by sjamaan, 11 years ago

Add exit-handler to the export list, and define it...

File size: 4.7 KB
Line 
1;;;; ssp-handler.scm
2;
3; Copyright (c) 2007, Peter Bex
4; Copyright (c) 2000-2005, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of the author nor the names of its
17;    contributors may be used to endorse or promote products derived
18;    from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32;
33; SSP file handler
34
35(module ssp-handler
36  (ssp-handler include-ssp ssp-stringize ssp-short-open-tag ssp-long-open-tag
37   ssp-close-tag ssp-eval-environment current-workdir exit-handler)
38
39(import chicken scheme spiffy extras ports regex files posix)
40(require-extension matchable intarweb)
41
42(define current-workdir (make-parameter #f))
43(define exit-handler    (make-parameter #f))
44
45(define ssp-eval-environment (make-parameter (interaction-environment)))
46
47(define (ssp-handler fn)
48  (let ([out (ssp-stringize fn)])
49  (with-headers `((content-type text/html)
50                  (content-length ,(string-length out)))
51    (lambda ()
52      (write-response (current-response))
53      (display out (response-port (current-response)))))))
54
55(define ssp-close-tag "\\?>")
56(define ssp-short-open-tag "<\\?")
57(define ssp-long-open-tag "<\\?scheme($|[ \n\t])")
58
59(define (translate-file fname)
60  (let* ([new (pathname-replace-extension fname "sspx")]
61         [rx (regexp (string-append ssp-long-open-tag "|" ssp-short-open-tag))]
62         [rx2 (regexp ssp-close-tag)] 
63         [buffer (with-input-from-file fname read-string)] )
64    (define (scan pos)
65      (match (string-search-positions rx buffer pos)
66        [((start end) . _)
67         (slashify (substring buffer pos start))
68         (display "\")\n")
69         (let ([s (string-match ssp-short-open-tag (substring buffer start end))])
70           (when s (display "(display "))
71           (skip end s) ) ]
72        [_ (slashify (substring buffer pos (string-length buffer)))
73           (display "\") )\n; End of file\n") ] ) )
74    (define (skip pos f)
75      (match (string-search-positions rx2 buffer pos)
76        [((start end) . _)
77         (display (substring buffer pos start))
78         (when f (write-char #\)))
79         (display "\n(display \"")
80         (scan end) ]
81        [_ #;(log 'debug "Warning: missing closing tag (~S)" ssp-close-tag)
82           (display "\n; Warning: missing closing tag\n") ] ) )
83    (define (slashify-char c)
84      (case c
85        [(#\newline) (display "\\n")]
86        [(#\return) (display "\\r")]
87        [(#\tab) (display "\\t")]
88        [(#\") (display "\\\"")]
89        [(#\\) (display "\\\\")]
90        [else (write-char c)] ) )
91    (define (slashify s)
92      (do ([i 0 (add1 i)])
93          ((>= i (string-length s)))
94        (slashify-char (string-ref s i))))
95    (with-output-to-file new
96      (lambda ()
97        (printf "; Translation of file ~A:\n(let () (display \"" fname)
98        (scan 0)))))
99
100(define (ssp-stringize path)
101  (let* ((cwd (current-workdir))
102         (fn (make-pathname (make-pathname (root-path) cwd) path)))
103    (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
104      (let ([fn2 (pathname-replace-extension fn "sspx")])
105        (when (or (not (file-exists? fn2)) (< (file-modification-time fn2) (file-modification-time fn)))
106              #;(log 'debug "(ssp) translating file ~A ..." fn)
107              (translate-file fn))
108        (load-scheme fn2)))))
109
110(define (load-scheme fn)
111  (with-output-to-string
112    (lambda ()
113      (load-scheme-file fn))))
114
115(define (include-ssp fn)
116  (display (ssp-stringize fn)))
117
118(define (load-scheme-file filename)
119  #;(log 'debug "Loading ~A ..." filename)
120  (call/cc
121   (lambda (return)
122     (parameterize ((load-verbose #f)
123                    (exit-handler (lambda _ (return #f))))
124       (load filename (cut eval <> (ssp-eval-environment)))))))
125
126)
Note: See TracBrowser for help on using the repository browser.