1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: genpage.lisp
6 ;;;; Purpose: HTML Pages creation functions
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Jun 2003
12 ;;;; This file, part of wol, is Copyright (c) 2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
17 (defvar *header-table* (make-hash-table :size 100 :test 'eq)
18 "Table of header functions indexed by site")
19 (defvar *banner-table* (make-hash-table :size 100 :test 'eq)
20 "Table of banner functions indexed by site")
21 (defvar *contents-table* (make-hash-table :size 100 :test 'eq)
22 "Table of table of content functions indexed by site")
23 (defvar *page-table* (make-hash-table :size 100 :test 'equal)
24 "Table of page functions indexed by site-pagename")
25 (defvar *footer-table* (make-hash-table :size 100 :test 'eq)
26 "Table of footer functions indexed by site")
28 (defun maybe-gen-header (site plist command)
29 (awhen (gethash site *header-table*) (funcall it plist command)))
31 (defun maybe-gen-footer (site plist command)
32 (awhen (gethash site *footer-table*) (funcall it plist command)))
34 (defun maybe-gen-banner (site plist command)
35 (awhen (gethash site *banner-table*) (funcall it plist command)))
37 (defun maybe-gen-contents (site plist command)
38 (awhen (gethash site *contents-table*) (funcall it plist command)))
40 (defmacro def-stdsite-header (site &body body)
41 `(setf (gethash ',site *header-table*)
42 #'(lambda (plist command)
43 (declare (ignorable plist command))
46 (defmacro def-stdsite-footer (site &body body)
47 `(setf (gethash ',site *footer-table*)
48 #'(lambda (plist command)
49 (declare (ignorable plist command))
52 (defmacro def-stdsite-banner (site &body body)
53 `(setf (gethash ',site *banner-table*)
54 #'(lambda (plist command)
55 (declare (ignorable plist command))
58 (defmacro def-stdsite-contents (site &body body)
59 `(setf (gethash ',site *contents-table*)
60 #'(lambda (plist command)
61 (declare (ignorable plist command))
65 (defmacro gen-std-head (title site plist command &body body)
69 (html (:title ,title)))
70 (maybe-gen-header ',site ,plist ,command)
73 (defmacro gen-std-footer (site plist command)
75 ((:div class "disclaimsec")
76 (maybe-gen-footer ',site ,plist ,command))))
79 (defmacro gen-std-body (site plist command &body body)
81 ;;(maybe-gen-banner ',site ,plist ,command)
83 ((:div class "stdbodytable")
84 ((:div :style "width:160px;position:fixed;left:3;right:auto;top:0")
85 ((:img :src "/images/umlisp-logo.png" :alt "logo"
86 :style "border:0;width:160;height:55"))
87 (maybe-gen-contents ',site ,plist ,command))
88 ((:div :style "position:absolute;left:170px;top:0")
90 "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
91 "High Performance Common Lisp Interface to the Unified Medical Langauge System")
93 (gen-std-footer ,site ,plist ,command))))))
96 (defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss)
99 ((:link :rel "stylesheet" :href css :type "text/css"))
102 ((:link :rel "stylesheet" :type "text/css"
103 :href (if (eq altcss t)
104 "http://b9.com/umls.css" altcss)))))
106 (html (:title (lml-write-string title-str)))))))
108 (defun page-prologue (title format css altcss)
111 (dtd-prologue format)
112 (lml-format "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
113 (aif css it "http://b9.com/umlsxml.css"))
114 (lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
115 (lml-write-char #\Newline)
117 (lml-format "<pagetitle>~A</pagetitle>" title))
118 (lml-write-char #\Newline))
120 (dtd-prologue format)
121 (lml-write-string "<html>")
122 (ml-head title (aif css it "http://b9.com/main.css") altcss)
123 (lml-write-string "<body>"))
124 ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
126 (dtd-prologue format)
128 "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">")
129 (ml-head title (aif css it "http://b9.com/main.css") altcss)
130 (lml-write-string "<body>"))
135 (defun page-epilogue (format)
137 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
139 (lml-write-string "</body></html>"))
141 (lml-print "</pagedata>"))
148 (defun page-keyword-format (format)
150 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
158 (defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
160 (let ((fmt (gensym "FMT-")))
161 `(let ((,fmt ,format))
162 (with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
163 (let ((*html-stream* *modlisp-socket*))
166 (page-prologue ,title ,format ,css ,altcss)
168 (page-epilogue ,format)))))))
171 (defmacro gen-std-page ((site plist command title &key css altcss
172 (precompute t) (format :xhtml))
174 `(let ((*print-circle* nil))
175 (with-lml-page (,title :css ,css :altcss ,altcss :format ,format
176 :precompute ,precompute)
177 (gen-std-body ,site ,plist ,command ,@body))))
182 (defmacro with-ml-link ((href &key (format :html)) &rest body)
185 (lml-princ "<xmllink xlink:type=\"simple\" xlink:href=\"")
189 (lml-princ "</xmllink>"))
191 (lml-princ "<html:a href=\"")
195 (lml-princ "</html:a>"))
196 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
198 (lml-princ "<a href=\"")
202 (lml-princ "</a>"))))
204 (defun ml-link (page name session-id &key (format :html))
206 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
209 ((:div class "homelink")
211 (with-ml-link ((make-ml-url page :session-id session-id :html t))
212 (lml-write-string name))
215 (lml-princ "<homelink>Return to ")
216 (with-ml-link ((make-ml-url page :session-id session-id :html t)
218 (lml-write-string name))
219 (lml-write-string " page.</homelink>"))))
221 (defun ml-home-link (session-id &key (format :html))
222 (ml-link "index" "home" session-id :format format))
224 (defun ml-search-link (session-id &key (format :html))
225 (ml-link "search" "search" session-id :format format))