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

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

load-verbose should be #f in spiffy

File size: 4.6 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)
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
44(define ssp-eval-environment (make-parameter (interaction-environment)))
45
46(define (ssp-handler fn)
47  (let ([out (ssp-stringize fn)])
48  (with-headers `((content-type text/html)
49                  (content-length ,(string-length out)))
50    (lambda ()
51      (write-response (current-response))
52      (display out (response-port (current-response)))))))
53
54(define ssp-close-tag "\\?>")
55(define ssp-short-open-tag "<\\?")
56(define ssp-long-open-tag "<\\?scheme($|[ \n\t])")
57
58(define (translate-file fname)
59  (let* ([new (pathname-replace-extension fname "sspx")]
60         [rx (regexp (string-append ssp-long-open-tag "|" ssp-short-open-tag))]
61         [rx2 (regexp ssp-close-tag)] 
62         [buffer (with-input-from-file fname read-string)] )
63    (define (scan pos)
64      (match (string-search-positions rx buffer pos)
65        [((start end) . _)
66         (slashify (substring buffer pos start))
67         (display "\")\n")
68         (let ([s (string-match ssp-short-open-tag (substring buffer start end))])
69           (when s (display "(display "))
70           (skip end s) ) ]
71        [_ (slashify (substring buffer pos (string-length buffer)))
72           (display "\") )\n; End of file\n") ] ) )
73    (define (skip pos f)
74      (match (string-search-positions rx2 buffer pos)
75        [((start end) . _)
76         (display (substring buffer pos start))
77         (when f (write-char #\)))
78         (display "\n(display \"")
79         (scan end) ]
80        [_ #;(log 'debug "Warning: missing closing tag (~S)" ssp-close-tag)
81           (display "\n; Warning: missing closing tag\n") ] ) )
82    (define (slashify-char c)
83      (case c
84        [(#\newline) (display "\\n")]
85        [(#\return) (display "\\r")]
86        [(#\tab) (display "\\t")]
87        [(#\") (display "\\\"")]
88        [(#\\) (display "\\\\")]
89        [else (write-char c)] ) )
90    (define (slashify s)
91      (do ([i 0 (add1 i)])
92          ((>= i (string-length s)))
93        (slashify-char (string-ref s i))))
94    (with-output-to-file new
95      (lambda ()
96        (printf "; Translation of file ~A:\n(let () (display \"" fname)
97        (scan 0)))))
98
99(define (ssp-stringize path)
100  (let* ((cwd (current-workdir))
101         (fn (make-pathname (make-pathname (root-path) cwd) path)))
102    (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
103      (let ([fn2 (pathname-replace-extension fn "sspx")])
104        (when (or (not (file-exists? fn2)) (< (file-modification-time fn2) (file-modification-time fn)))
105              #;(log 'debug "(ssp) translating file ~A ..." fn)
106              (translate-file fn))
107        (load-scheme fn2)))))
108
109(define (load-scheme fn)
110  (with-output-to-string
111    (lambda ()
112      (load-scheme-file fn))))
113
114(define (include-ssp fn)
115  (display (ssp-stringize fn)))
116
117(define (load-scheme-file filename)
118  #;(log 'debug "Loading ~A ..." filename)
119  (call/cc
120   (lambda (return)
121     (parameterize ((load-verbose #f)
122                    (exit-handler (lambda _ (return #f))))
123       (load filename (cut eval <> (ssp-eval-environment)))))))
124
125)
Note: See TracBrowser for help on using the repository browser.