;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jun 2003
;;;;
-;;;; $Id: genpage.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of wol, is Copyright (c) 2003 by Kevin M. Rosenberg
;;;; *************************************************************************
-(in-package #:wol)
+(in-package wol)
(defvar *header-table* (make-hash-table :size 100 :test 'eq)
"Table of header functions indexed by site")
(defmacro def-stdsite-header (site &body body)
`(setf (gethash ',site *header-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro def-stdsite-footer (site &body body)
`(setf (gethash ',site *footer-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro def-stdsite-banner (site &body body)
`(setf (gethash ',site *banner-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro def-stdsite-contents (site &body body)
`(setf (gethash ',site *contents-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro gen-std-head (title site plist command &body body)
`(html
- (:head
+ (:head
(when ,title
(html (:title ,title)))
(maybe-gen-header ',site ,plist ,command)
(html
((:div class "stdbodytable")
((:div :style "width:160px;position:fixed;left:3;right:auto;top:0")
- ((:img :src "/images/umlisp-logo.png" :alt "logo"
- :style "border:0;width:160;height:55"))
+ ((:img :src "/images/umlisp-logo.png" :alt "logo"
+ :style "border:0;width:160;height:55"))
(maybe-gen-contents ',site ,plist ,command))
((:div :style "position:absolute;left:170px;top:0")
((:div :style
- "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
- "High Performance Common Lisp Interface to the Unified Medical Langauge System")
+ "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
+ "High Performance Common Lisp Interface to the Unified Medical Langauge System")
,@body
- (gen-std-footer ,site ,plist ,command))))))
+ (gen-std-footer ,site ,plist ,command))))))
-(defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss)
+(defun ml-head (title-str &optional (css "http://kpe.io/main.css") altcss)
(html
(:head
((:link :rel "stylesheet" :href css :type "text/css"))
(when altcss
(html
((:link :rel "stylesheet" :type "text/css"
- :href (if (eq altcss t)
- "http://b9.com/umls.css" altcss)))))
+ :href (if (eq altcss t)
+ "http://kpe.io/umls.css" altcss)))))
(when title-str
(html (:title (lml-write-string title-str)))))))
-
(defun page-prologue (title format css altcss)
(ecase format
(:xml
(dtd-prologue format)
(lml-format "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
- (aif css it "http://b9.com/umlsxml.css"))
+ (aif css it "http://kpe.io/umlsxml.css"))
(lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
(lml-write-char #\Newline)
(when title
(:html
(dtd-prologue format)
(lml-write-string "<html>")
- (ml-head title (aif css it "http://b9.com/main.css") altcss)
+ (ml-head title (aif css it "http://kpe.io/main.css") altcss)
(lml-write-string "<body>"))
((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
:xhtml10-frameset)
(dtd-prologue format)
(lml-write-string
"<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">")
- (ml-head title (aif css it "http://b9.com/main.css") altcss)
+ (ml-head title (aif css it "http://kpe.io/main.css") altcss)
(lml-write-string "<body>"))
(:text
;; nothing to do
(defun page-keyword-format (format)
(ecase format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
- :xhtml10-frameset)
+ :xhtml10-frameset)
:html)
(:xml
:xml)
:text)))
(defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
- &rest body)
+ &rest body)
(let ((fmt (gensym "FMT-")))
`(let ((,fmt ,format))
(with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
- (let ((*html-stream* *modlisp-socket*))
- (prog1
- (progn
- (page-prologue ,title ,format ,css ,altcss)
- ,@body)
- (page-epilogue ,format)))))))
+ (let ((*html-stream* *modlisp-socket*))
+ (prog1
+ (progn
+ (page-prologue ,title ,format ,css ,altcss)
+ ,@body)
+ (page-epilogue ,format)))))))
(defmacro gen-std-page ((site plist command title &key css altcss
- (precompute t) (format :xhtml))
- &body body)
+ (precompute t) (format :xhtml))
+ &body body)
`(let ((*print-circle* nil))
(with-lml-page (,title :css ,css :altcss ,altcss :format ,format
- :precompute ,precompute)
+ :precompute ,precompute)
(gen-std-body ,site ,plist ,command ,@body))))
,@body
(lml-princ "</html:a>"))
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
- :xhtml10-frameset)
+ :xhtml10-frameset)
(lml-princ "<a href=\"")
(lml-princ ,href)
(lml-princ "\">")
(defun ml-link (page name session-id &key (format :html))
(case format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
- :xhtml10-frameset)
+ :xhtml10-frameset)
(html
((:div class "homelink")
"Return to "
(with-ml-link ((make-ml-url page :session-id session-id :html t))
- (lml-write-string name))
+ (lml-write-string name))
" page.")))
((:xml :ie-xml)
(lml-princ "<homelink>Return to ")
(with-ml-link ((make-ml-url page :session-id session-id :html t)
- :format format)
+ :format format)
(lml-write-string name))
(lml-write-string " page.</homelink>"))))