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
10 ;;;; $Id: genpage.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
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)))))))
109 (defun page-prologue (title format css altcss)
112 (dtd-prologue format)
113 (lml-format "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
114 (aif css it "http://b9.com/umlsxml.css"))
115 (lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
116 (lml-write-char #\Newline)
118 (lml-format "<pagetitle>~A</pagetitle>" title))
119 (lml-write-char #\Newline))
121 (dtd-prologue format)
122 (lml-write-string "<html>")
123 (ml-head title (aif css it "http://b9.com/main.css") altcss)
124 (lml-write-string "<body>"))
125 ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
127 (dtd-prologue format)
129 "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">")
130 (ml-head title (aif css it "http://b9.com/main.css") altcss)
131 (lml-write-string "<body>"))
136 (defun page-epilogue (format)
138 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
140 (lml-write-string "</body></html>"))
142 (lml-print "</pagedata>"))
149 (defun page-keyword-format (format)
151 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
159 (defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
161 (let ((fmt (gensym "FMT-")))
162 `(let ((,fmt ,format))
163 (with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
164 (let ((*html-stream* *modlisp-socket*))
167 (page-prologue ,title ,format ,css ,altcss)
169 (page-epilogue ,format)))))))
172 (defmacro gen-std-page ((site plist command title &key css altcss
173 (precompute t) (format :xhtml))
175 `(let ((*print-circle* nil))
176 (with-lml-page (,title :css ,css :altcss ,altcss :format ,format
177 :precompute ,precompute)
178 (gen-std-body ,site ,plist ,command ,@body))))
183 (defmacro with-ml-link ((href &key (format :html)) &rest body)
186 (lml-princ "<xmllink xlink:type=\"simple\" xlink:href=\"")
190 (lml-princ "</xmllink>"))
192 (lml-princ "<html:a href=\"")
196 (lml-princ "</html:a>"))
197 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
199 (lml-princ "<a href=\"")
203 (lml-princ "</a>"))))
205 (defun ml-link (page name session-id &key (format :html))
207 ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
210 ((:div class "homelink")
212 (with-ml-link ((make-ml-url page :session-id session-id :html t))
213 (lml-write-string name))
216 (lml-princ "<homelink>Return to ")
217 (with-ml-link ((make-ml-url page :session-id session-id :html t)
219 (lml-write-string name))
220 (lml-write-string " page.</homelink>"))))
222 (defun ml-home-link (session-id &key (format :html))
223 (ml-link "index" "home" session-id :format format))
225 (defun ml-search-link (session-id &key (format :html))
226 (ml-link "search" "search" session-id :format format))