;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.14 2003/07/15 16:52:23 kevin Exp $
+;; $Id: htmlgen.lisp,v 1.15 2003/07/15 19:25:28 kevin Exp $
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
;; - Support XHTML end tags
;; - lowercase symbol names for attributes
;; - Add custom tags such as :jscript, :insert-file, :load-file, :nbsp
-;; - removal of if* macro -- partially complete
+;; - removal of if* macro
+;; - Add attribute conditions
+;; - Automatic conversion to strings for attribute values
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; body is the body if any of the form
;;
(let (spec)
- (if* (setq spec (html-process-special ent))
- then ; do something different
- (push (funcall spec ent args argsp body) res)
- elseif (null argsp)
- then ; singleton tag, just do the set
- (push `(,(html-process-macro ent) :set) res)
- nil
- else (if* (equal args '(:unset))
- then ; ((:tag :unset)) is a special case.
- ; that allows us to close off singleton tags
- ; printed earlier.
- (push `(,(html-process-macro ent) :unset) res)
- nil
- else ; some args
- (push `(,(html-process-macro ent)
- ,args
- ,(process-html-forms body env))
- res)
- nil)))))
-
+ (cond
+ ((setq spec (html-process-special ent))
+ ;; do something different
+ (push (funcall spec ent args argsp body) res))
+ ((null argsp)
+ ;; singleton tag, just do the set
+ (push `(,(html-process-macro ent) :set) res)
+ nil)
+ (t
+ (cond ((equal args '(:unset))
+ ;; ((:tag :unset)) is a special case.
+ ;; that allows us to close off singleton tags
+ ;; printed earlier.
+ (push `(,(html-process-macro ent) :unset) res)
+ nil)
+ (t
+ ;; some args
+ (push `(,(html-process-macro ent)
+ ,args
+ ,(process-html-forms body env))
+ res)
+ nil)))))))
(do* ((xforms forms (cdr xforms))
(setq form (macroexpand form env))
- (if* (atom form)
- then (if* (keywordp form)
- then (let ((ent (gethash form *html-process-table*)))
- (if (null ent)
- (error "unknown html keyword ~s" form)
- (do-ent ent nil nil nil)))
- elseif (stringp form)
- then ; turn into a print of it
- (push `(write-string ,form *html-stream*) res)
- else (push form res))
- else (let ((first (car form)))
- (if* (keywordp first)
- then ; (:xxx . body) form
- (let ((ent (gethash first
- *html-process-table*)))
- (if (null ent)
- (error "unknown html keyword ~s" form)
- (do-ent ent nil t (cdr form))))
- elseif (and (consp first) (keywordp (car first)))
- then ; ((:xxx args ) . body)
- (let ((ent (gethash (car first)
- *html-process-table*)))
- (if (null ent)
- (error "unknown html keyword ~s" form)
- (do-ent ent (cdr first) t (cdr form))))
- else (push form res))))))
+ (if (atom form)
+ (cond
+ ((keywordp form)
+ (let ((ent (gethash form *html-process-table*)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent nil nil nil))))
+ ((stringp form)
+ ;; turn into a print of it
+ (push `(write-string ,form *html-stream*) res))
+ (t
+ (push form res)))
+ (let ((first (car form)))
+ (cond
+ ((keywordp first)
+ ;; (:xxx . body) form
+ (let ((ent (gethash first
+ *html-process-table*)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent nil t (cdr form)))))
+ ((and (consp first) (keywordp (car first)))
+ ;; ((:xxx args ) . body)
+ (let ((ent (gethash (car first)
+ *html-process-table*)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent (cdr first) t (cdr form)))))
+ (t
+ (push form res)))))))
`(progn ,@(nreverse res))))
((null xx)
(nreverse res))
(case name
- (:if*
- (push `(if* ,value
- then (write-string ,(format nil " ~(~a~)" (third xx))
- *html-stream*)
- (prin1-safe-http-string ,(fourth xx)))
- res)
- (pop xx) (pop xx))
(:fformat
(unless (and (listp value)
(>= (length value) 2))
(fformat nil ,(second value) ,@(cddr value)))
res))
(:optional
- (push `(when ,(second value)
- (write-string
- ,(format nil " ~(~a~)" (first value))
- *html-stream*)
- (prin1-safe-http-string ,(second value)))
- res))
+ (let ((eval-if (gensym "EVAL-IF-")))
+ (push `(let ((,eval-if ,(second value)))
+ (when ,eval-if
+ (write-string
+ ,(format nil " ~(~a~)" (first value))
+ *html-stream*)
+ (prin1-safe-http-string ,eval-if)))
+ res)))
(:if
(unless (and (listp value)
(>= (length value) 3)
,(third value)
,(fourth value))))
res)))
+ (:when
+ (unless (and (listp value)
+ (= (length value) 3))
+ (error ":when must be given a list with 3 elements"))
+ (push `(when ,(second value)
+ (write-string ,(format nil " ~(~a~)" (first value))
+ *html-stream*)
+ (prin1-safe-http-string ,(third value)))
+ res))
(t
(push `(write-string ,(format nil " ~(~a~)" name) *html-stream*)
res)
;; print the contents inside a string double quotes (which should
;; not be turned into "'s
;; symbols are turned into their name
+ ;;
+ ;; non-string and non-symbols are written to a string and quoted
+
(unless (and (symbolp val)
(equal "" (symbol-name val)))
(write-char #\= *html-stream*)
+ (when (not (or (stringp val)
+ (symbolp val)))
+ (setq val (write-to-string val)))
(if (or (stringp val)
(and (symbolp val)
(setq val (string-downcase
(when (< start i)
(write-sequence string stream :start start :end i)))
- (let ((ch (schar string i))
- (cvt ))
- (if* (eql ch #\<)
- then (setq cvt "<")
- elseif (eq ch #\>)
- then (setq cvt ">")
- elseif (eq ch #\&)
- then (setq cvt "&")
- elseif (eq ch #\")
- then (setq cvt """))
+ (let* ((ch (schar string i))
+ (cvt (case ch
+ (#\< "<")
+ (#\> ">")
+ (#\& "&")
+ (#\" """))))
(when cvt
;; must do a conversion, emit previous chars first
-
(when (< start i)
(write-sequence string stream :start start :end i))
(write-string cvt stream)
-
(setq start (1+ i))))))
(let* ((attrs)
(attr-name)
(name)
- (possible-kwd (if* (atom form)
- then form
- elseif (consp (car form))
- then (setq attrs (cdar form))
- (caar form)
- else (car form)))
+ (possible-kwd (cond
+ ((atom form) form)
+ ((consp (car form))
+ (setq attrs (cdar form))
+ (caar form))
+ (t (car form))))
print-handler
ent)
- (if* (keywordp possible-kwd)
- then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
- then (if unknown
- (return-from html-print-subst
- (funcall unknown form stream))
- (error "unknown html tag: ~s" possible-kwd))
- else ; see if we should subst
- (if* (and subst
- attrs
- (setq attr-name (html-process-name-attr ent))
- (setq name (getf attrs attr-name))
- (setq attrs (html-find-value name subst)))
- then
- (return-from html-print-subst
- (if* (functionp (cdr attrs))
- then
- (funcall (cdr attrs) stream)
- else (html-print-subst
- (cdr attrs)
- subst
- stream
- unknown)))))
-
- (setq print-handler
- (html-process-print ent)))
- (if* (atom form)
- then (if* (keywordp form)
- then (funcall print-handler ent :set nil nil nil nil stream)
- elseif (stringp form)
- then (write-string form stream)
- else (princ form stream))
- elseif ent
- then (funcall print-handler
- ent
- :full
- (when (consp (car form)) (cdr (car form)))
- form
- subst
- unknown
- stream)
- else (error "Illegal form: ~s" form))))
+ (when (keywordp possible-kwd)
+ (if (null (setq ent (gethash possible-kwd *html-process-table*)))
+ (if unknown
+ (return-from html-print-subst
+ (funcall unknown form stream))
+ (error "unknown html tag: ~s" possible-kwd))
+ ;; see if we should subst
+ (when (and subst
+ attrs
+ (setq attr-name (html-process-name-attr ent))
+ (setq name (getf attrs attr-name))
+ (setq attrs (html-find-value name subst)))
+ (return-from html-print-subst
+ (if (functionp (cdr attrs))
+ (funcall (cdr attrs) stream)
+ (html-print-subst
+ (cdr attrs)
+ subst
+ stream
+ unknown)))))
+
+ (setq print-handler
+ (html-process-print ent)))
+
+ (cond
+ ((atom form)
+ (cond
+ ((keywordp form)
+ (funcall print-handler ent :set nil nil nil nil stream))
+ ((stringp form)
+ (write-string form stream))
+ (t
+ (princ form stream))))
+ (ent
+ (funcall print-handler
+ ent
+ :full
+ (when (consp (car form)) (cdr (car form)))
+ form
+ subst
+ unknown
+ stream))
+ (t
+ (error "Illegal form: ~s" form)))))
(defun html-find-value (key subst)
(do* ((entlist alist (cdr entlist))
(ent (car entlist) (car entlist)))
((null entlist) (setq alist nil))
- (if* (consp (car ent))
- then ; this is another alist
- (when (cdr entlist)
- (push (cdr entlist) to-process))
- (setq alist ent)
- (return) ; exit do*
- elseif (equal key (car ent))
- then (return-from html-find-value ent)))
+ (cond
+ ((consp (car ent))
+ ;; this is another alist
+ (when (cdr entlist)
+ (push (cdr entlist) to-process))
+ (setq alist ent)
+ (return)) ; exit do*
+ ((equal key (car ent))
+ (return-from html-find-value ent))))
- (if* (null alist)
- then ; we need to find a new alist to process
-
- (if to-process
- (setq alist (pop to-process))
- (return))))))
+ (when (null alist)
+ ;; we need to find a new alist to process
+ (if to-process
+ (setq alist (pop to-process))
+ (return))))))
(defun html-standard-print (ent cmd args form subst unknown stream)
;; the print handler for the normal html operators
(format stream "<~a>" (html-process-key ent)))
(:full ; set, do body and then unset
(let (iter)
- (if* args
- then (if* (and (setq iter (getf args :iter))
- (setq iter (html-find-value iter subst)))
- then ; remove the iter and pre
- (setq args (copy-list args))
- (remf args :iter)
- (funcall (cdr iter)
- (cons (cons (caar form)
- args)
- (cdr form))
- subst
- stream)
- (return-from html-standard-print)
- else
- (format stream "<~a" (html-process-key ent))
- (do ((xx args (cddr xx)))
- ((null xx))
- ; assume that the arg is already escaped
- ; since we read it
- ; from the parser
- (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
- (format stream ">"))
- else (format stream "<~a>" (html-process-key ent)))
+ (if args
+ (cond
+ ((and (setq iter (getf args :iter))
+ (setq iter (html-find-value iter subst)))
+ ;; remove the iter and pre
+ (setq args (copy-list args))
+ (remf args :iter)
+ (funcall (cdr iter)
+ (cons (cons (caar form)
+ args)
+ (cdr form))
+ subst
+ stream)
+ (return-from html-standard-print))
+ (t
+ (format stream "<~a" (html-process-key ent))
+ (do ((xx args (cddr xx)))
+ ((null xx))
+ ; assume that the arg is already escaped
+ ; since we read it
+ ; from the parser
+ (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
+ (format stream ">")))
+ (format stream "<~a>" (html-process-key ent)))
(dolist (ff (cdr form))
(html-print-subst ff subst stream unknown)))
(when (html-process-has-inverse ent)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: lml-tests.lisp
-;;;; Purpose: lml tests file
+;;;; Name: tests.lisp
+;;;; Purpose: tests file
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
-;;;; $Id: tests.lisp,v 1.2 2003/07/12 17:54:05 kevin Exp $
+;;;; $Id: tests.lisp,v 1.3 2003/07/15 19:25:28 kevin Exp $
;;;;
;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg.
;;;; Rights of modification and redistribution are in the LICENSE file.
(in-package #:cl)
(defpackage #:lml-tests
- (:use #:lml #:cl #:rtest))
+ (:use #:lml2 #:cl #:rtest))
(in-package #:lml-tests)
(rem-all-tests)
(deftest lml.0
(with-output-to-string (s)
- (let ((*html-output* s))
- (div)))
+ (let ((*html-stream* s))
+ (html (:div))))
"<div></div>")
(deftest lml.1
(with-output-to-string (s)
- (let ((*html-output* s))
- (span-c foo "Foo Bar")))
+ (let ((*html-stream* s))
+ (html ((:span class 'foo) "Foo Bar"))))
"<span class=\"foo\">Foo Bar</span>")
(deftest lml.2
(with-output-to-string (s)
- (let ((*html-output* s))
- (table-c foo :style "width:80%" "Foo" " Bar" " test")))
+ (let ((*html-stream* s))
+ (html ((:table class "foo" :style "width:80%")
+ "Foo" " Bar" " test"))))
"<table class=\"foo\" style=\"width:80%\">Foo Bar test</table>")
(deftest lml.3
(with-output-to-string (s)
- (let ((*html-output* s)
+ (let ((*html-stream* s)
(a 5.5d0))
- (p a)))
+ (html (:p (:princ a)))))
"<p>5.5d0</p>")
(deftest lml.4
(with-output-to-string (s)
- (let ((*html-output* s)
+ (let ((*html-stream* s)
(a 0.75))
- (img "http://localhost/test.png" :width a)))
+ (html ((:img :src "http://localhost/test.png" :width a)))))
"<img src=\"http://localhost/test.png\" width=\"0.75\" />")
(deftest lml.5
(with-output-to-string (s)
- (let ((*html-output* s))
- (div "Start"
- (p "Testing"))))
+ (let ((*html-stream* s))
+ (html
+ (:div "Start"
+ (:p "Testing")))))
"<div>Start<p>Testing</p></div>")
(deftest lml.6
(with-output-to-string (s)
- (let ((*html-output* s))
- (div :style "font-weight:bold"
- "Start"
- (p-c a_class "Testing"))))
+ (let ((*html-stream* s))
+ (html
+ ((:div :style "font-weight:bold")
+ "Start"
+ ((:p class 'a_class) "Testing")))))
"<div style=\"font-weight:bold\">Start<p class=\"a_class\">Testing</p></div>")
+(deftest lml.7
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (class "aclass"))
+ (html
+ ((:div :optional (:class class))
+ "bod"))))
+ "<div class=\"aclass\">bod</div>")
+
+(deftest lml.8
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (class nil))
+ (html
+ ((:div :optional (:class class))
+ "bod"))))
+ "<div>bod</div>")
+
+(deftest lml.9
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (do-class t)
+ (class "aclass"))
+ (html
+ ((:div :when (:class do-class class))
+ "bod"))))
+ "<div class=\"aclass\">bod</div>")
+
+(deftest lml.10
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (do-class nil)
+ (class "aclass"))
+ (html
+ ((:div :when (:class do-class class))
+ "bod"))))
+ "<div>bod</div>")
+
+
+(deftest lml.11
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (v 10))
+ (html
+ ((:div :fformat (:onclick "a&b('~A')" v))))))
+ "<div onclick=\"a&b('10')\"></div>")
+
+(deftest lml.12
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (v 10))
+ (html
+ ((:div :format (:onclick "a&b('~A')" v))))))
+ "<div onclick=\"a&b('10')\"></div>")
+
+(deftest lml.13
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (selector t)
+ (v 10))
+ (html
+ ((:div :if (:width selector 1 2))))))
+ "<div width=\"1\"></div>")
+
+(deftest lml.14
+ (with-output-to-string (s)
+ (let ((*html-stream* s)
+ (selector nil)
+ (v 10))
+ (html
+ ((:div :if (:width selector 1 2))))))
+ "<div width=\"2\"></div>")
projects / lml2.git / commitdiff