1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: imho -*-
;;; $Id: response-head.lisp,v 1.15 2001/11/12 20:07:08 jesse Exp $
;;;
;;; Copyright (c) 1999, 2000, 2001 onShore Development, Inc.
;;;
;;; See the file 'COPYING' in this directory for terms.
(in-package :imho)
;; ------------------------------------------------------------
;; Support insertion of style sheets and blocks of javascript code
;; into a document.
;; A structure that records the content of a file and its modification
;; time.
(defstruct html-script
file-name
file-date
content)
;; ------------------------------------------------------------
;; function: read-file-fully
;;
;; Read a file into a string.
(defun read-file-fully (filename)
"Read the contents of FILENAME, return an instance of HTML-SCRIPT."
(let ((pathname (or
(ignore-errors (translate-logical-pathname filename))
filename)))
(if (probe-file pathname)
(with-open-file (stream pathname)
(let* ((length (file-length stream))
(seq (make-string length)))
(read-sequence seq stream)
(make-html-script :file-date (file-write-date pathname)
:file-name filename
:content seq)))
(make-html-script :file-name filename))))
;; 'foo => "foo"
(defvar *script-elements* (make-hash-table))
(defun script-name (class)
(or (gethash class *script-elements*)
(setf (gethash class *script-elements*)
(string-downcase (symbol-name class)))))
;; ------------------------------------------------------------
;; method: script-code
;;
;; Given an element's class and the application that the element
;; belongs to, pull the script text out of the filesystem.
(defun script-code (application element-class)
"Given APPLICATION and ELEMENT-CLASS, return the appropriate script
code, if it exists."
(with-slots (scripts script-root)
application
(let* ((key (script-name element-class))
(script (gethash key scripts)))
(if (and script
(equal (file-write-date (html-script-file-name script))
(html-script-file-date script)))
(html-script-content script)
(let ((filename (concatenate 'string script-root key ".js")))
(setq script (read-file-fully filename))
(setf (gethash key scripts) script)
(and script
(html-script-content script)))))))
(defvar *initializer-format*
"imho_instances[imho_instances.length] = new Array(~A, ~{\"~A\"~^, ~})")
(eval-when (:load-toplevel :compile-toplevel)
(defun scripted-element-init (&rest array-args)
"Assign an initialization function for a scriptable element."
(push (format nil *initializer-format* (car array-args) (cdr array-args))
(request-scripted-instances *active-request*)))
(defun write-layer (name attributes)
"Write a CSSP entry."
(let ((stream (or (request-css-entries *active-request*)
(setf (request-css-entries *active-request*)
(make-string-output-stream)))))
(format stream "~&#~a {~%" name)
(dolist (att attributes)
(format stream " ~a:~a;~%"
(car att)
(etypecase (cdr att)
(string (cdr att))
(number (format nil "~d" (cdr att))))))
(format stream "}~%~%")))
)
(defun write-script (application element-class stream)
"Write a block of script code."
(let ((code (script-code application element-class)))
(when code
(write-string "// Code for " stream)
(write-string (symbol-name element-class) stream)
(terpri stream)
(write-string code stream)
(terpri stream))))
|
