X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=web-utils-aserve.lisp;h=654866254e07c06fe39b0638a7918b294a166477;hb=7847333b8ae50ed0a99839b484319358d6d8b0a9;hp=e7ae505970010eae142620ef16afbdd1c9357cad;hpb=64ab2587ad0923623832012abd1b8b2cf5a11a84;p=kmrcl.git

diff --git a/web-utils-aserve.lisp b/web-utils-aserve.lisp
index e7ae505..6548662 100644
--- a/web-utils-aserve.lisp
+++ b/web-utils-aserve.lisp
@@ -7,16 +7,16 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: web-utils-aserve.lisp,v 1.3 2002/10/09 14:24:47 kevin Exp $
+;;;; $Id: web-utils-aserve.lisp,v 1.9 2002/10/18 05:14:49 kevin Exp $
 ;;;;
-;;;; This file, part of Kmrcl, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
-;;;; Kmrcl users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License.
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
 
-
 (in-package :kmrcl)
 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
 
@@ -60,64 +60,86 @@
   (with-tag-attribute "font" (format nil "size=\"~a\"" size)
 		      (princ-http text)))
 
-(defmacro with-link ((href xml linktype) &rest body)
-  (declare (ignore linktype))
+(defmacro with-link ((href &key (format :html)) &rest body)
 ;   (format *html-stream* "Return to <cui2 xml:href=\"qstr\">Home</cui2>")
 ;   (format *html-stream* "Return to <go xml:link=\"simple\" show=\"replace\" href=\"qstr/\">Home</go>")
-  `(if ,xml
-       (progn
-	 (princ-http "<elem xlink:type=\"simple\" xlink:href=\"")
-	 (princ-http ,href)
-	 (princ-http "\">")
-	 ,@body
-	 (princ-http "</elem>"))
-     (progn 
-       (princ-http "<a href=\"")
-       (princ-http ,href)
-       (princ-http "\">")
-       ,@body
-       (princ-http "</a>"))))
-
-(defun home-link (&key (xml nil) (vars nil))
-  (princ-http "<font size=\"-1\">Return to ")
-  (with-link ((make-url "index.html" :vars vars) xml "homelink")
-    (princ-http "Browser Home"))
-  (princ-http "</font><p></p>"))
-
-(defun head (title-str)
+  `(case ,format
+     (:xml
+      (princ-http "<elem xlink:type=\"simple\" xlink:href=\"")
+      (princ-http ,href)
+      (princ-http "\">")
+      ,@body
+      (princ-http "</elem>"))
+     (:ie-xml
+      (princ-http "<html:a href=\"")
+      (princ-http ,href)
+      (princ-http "\">")
+      ,@body
+      (princ-http "</html:a>"))
+     (:html
+      (princ-http "<a href=\"")
+      (princ-http ,href)
+      (princ-http "\">")
+      ,@body
+      (princ-http "</a>"))))
+
+(defun home-link (&key (format :html) (vars nil))
+  (case format
+    (:html
+     (princ-http "<div class=\"homelink\">Return to ")
+     (with-link ((make-url "index.html" :vars vars))
+		(princ-http "Home"))
+     (princ-http "</div>"))
+    ((:xml :ie-xml)
+     (princ-http "<homelink>Return to ")
+     (with-link ((make-url "index.html" :vars vars :format format) :format format)
+       (princ-http "Home"))
+     (princ-http "</homelink>"))))
+
+(defun head (title-str &key css)
+  (unless css
+    (setq css "http://b9.com/main.css"))
   (net.html.generator:html 
-   (:head 
-    "<LINK rel=\"stylesheet\" href=\"http://www.med-info.com/main.css\" type=\"text/css\">"
+   (:head
+    (princ-http (format nil "<link rel=\"stylesheet\" href=\"~A\" type=\"text/css\"></link>" css))
     (:title (:princ-safe title-str)))))
 
 
 
 ;;; Page wrappers
 
-(defmacro with-xml-page (title &rest body)
-  `(prog1
-       (progn
-	 (net.html.generator:html
-	  (princ-http (std-xml-header))
-	  (princ-http "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">"))
-	 (with-tag "pagetitle" (princ-http ,title))
-	 ,@body)
-     (princ-http "</pagedata>")))
-
-(defmacro with-trans-page (title &rest body)
-  `(prog1
-       (progn
-	  (print-http "<?xml version=\"1.0\" standalone=\"yes\"?>")
-	  (print-http "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
-	  (print-http " \"http://www.w3c.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
-	  (print-http "")
-	  (print-http "<html xmlns=\"http://www.w3.org/1999/xhtml\">")
-	  (head ,title)
-	  (print-http "<body bgcolor=\"#FFFFFF\">")
-	  (prog1 
-	      ,@body
-	    (print-http "</body>")))
-     (print-http "</html>")))
+(defmacro with-page ((title &key css (format :xhtml)) &rest body)
+  (case format
+    (:xhtml
+     `(prog1
+	  (progn
+	    (net.html.generator:html
+	     (print-http *standard-xhtml-header*)
+	     (print-http "<html xmlns=\"http://www.w3.org/1999/xhtml\">")
+	     (head ,title :css ,css)
+	     (print-http "<body>")
+	     (prog1 
+		 ,@body
+	       (print-http "</body></html>"))))))
+    (:html
+     `(prog1
+	  (progn
+	    (net.html.generator:html
+	     (print-http *standard-html-header*)
+	     (head ,title :css ,css)
+	     (print-http "<body>")
+	     (prog1 
+		 ,@body
+	       (print-http "</body></html>"))))))
+    (:xml
+     `(prog1
+	  (progn
+	    (net.html.generator:html
+	     (princ-http *standard-xml-header*)
+	     (princ-http "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">"))
+	    (with-tag "pagetitle" (princ-http ,title))
+	    ,@body)
+	(princ-http "</pagedata>")))))
 
 
 ;;; URL Encoding