Permalink
Browse files

initial commit

  • Loading branch information...
0 parents commit c5bd53b1d46bc362cbe413af8ac63696c4f15303 @youz committed Apr 5, 2012
Showing with 730 additions and 0 deletions.
  1. +11 −0 README.md
  2. +5 −0 site-lisp/xl-who.l
  3. +66 −0 site-lisp/xl-who/package.l
  4. +110 −0 site-lisp/xl-who/specials.l
  5. +487 −0 site-lisp/xl-who/who.l
  6. +51 −0 test/test.l
11 README.md
@@ -0,0 +1,11 @@
+# xl-who
+
+Edi Weitzの[CL-WHO](http://weitz.de/cl-who/) を xyzzy lisp へ移植したモノ
+
+## Author
+Yousuke Ushiki (<citrus.yubeshi@gmail.com>)
+
+[@Yubeshi](http://twitter.com/Yubeshi/)
+
+## License
+[BSD-style license](http://www.opensource.org/licenses/bsd-license.php)
5 site-lisp/xl-who.l
@@ -0,0 +1,5 @@
+;;; -*- mode:lisp; package:user -*-
+(in-package :user)
+
+(provide "xl-who")
+(require "xl-who/who")
66 site-lisp/xl-who/package.l
@@ -0,0 +1,66 @@
+;;; -*- mode: lisp; package: xl-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/packages.lisp,v 1.18 2008/03/27 23:17:55 edi Exp $
+
+;;; Copyright (c) 2003-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(provide "xl-who/package")
+
+(in-package :user)
+
+(defpackage :xl-who
+ (:use :lisp)
+ (:nicknames :who)
+ (:export #:*attribute-quote-char*
+ #:*escape-char-p*
+ #:*prologue*
+ #:*downcase-tokens-p*
+ #:*html-empty-tags*
+ #:*html-empty-tag-aware-p*
+ #:conc
+ #:convert-attributes
+ #:convert-tag-to-string-list
+ #:esc
+ #:escape-char
+ #:escape-char-all
+ #:escape-char-iso-8859-1
+ #:escape-char-minimal
+ #:escape-char-minimal-plus-quotes
+ #:escape-string
+ #:escape-string-all
+ #:escape-string-iso-8859
+ #:escape-string-iso-8859-1
+ #:escape-string-minimal
+ #:escape-string-minimal-plus-quotes
+ #:fmt
+ #:htm
+ #:html-mode
+ #:show-html-expansion
+ #:str
+ #:with-html-output
+ #:with-html-output-to-string))
+
+(pushnew :xl-who *features*)
110 site-lisp/xl-who/specials.l
@@ -0,0 +1,110 @@
+;;; -*- mode: lisp; package:xl-who; -*-
+;;; $Header: /usr/local/cvsrep/cl-who/specials.lisp,v 1.4 2008/03/27 23:17:55 edi Exp $
+
+;;; Copyright (c) 2003-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(provide "xl-who/specials")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "xl-who/package"))
+
+(in-package :xl-who)
+
+(defvar *prologue*
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
+ "This is the first line that'll be printed if the :PROLOGUE keyword
+argument is T")
+
+(defparameter *escape-char-p*
+ #'(lambda (char)
+ (or (find char "<>&'\"")
+ (> (char-code char) 127)))
+ "Used by ESCAPE-STRING to test whether a character should be escaped.")
+
+(defparameter *indent* nil
+ "Whether to insert line breaks and indent. Also controls amount of
+indentation dynamically.")
+
+(defvar *html-mode* :xml
+ ":SGML for \(SGML-)HTML, :XML \(default) for XHTML.")
+
+(defvar *downcase-tokens-p* t
+ "If NIL, a keyword symbol representing a tag or attribute name will
+not be automatically converted to lowercase. This is useful when one
+needs to output case sensitive XML.")
+
+(defparameter *attribute-quote-char* #\'
+ "Quote character for attributes.")
+
+(defparameter *empty-tag-end* " />"
+ "End of an empty tag. Default is XML style.")
+
+(defparameter *html-empty-tags*
+ '(:area
+ :atop
+ :audioscope
+ :base
+ :basefont
+ :br
+ :choose
+ :col
+ :frame
+ :hr
+ :img
+ :input
+ :isindex
+ :keygen
+ :left
+ :limittext
+ :link
+ :meta
+ :nextid
+ :of
+ :over
+ :param
+ :range
+ :right
+ :spacer
+ :spot
+ :tab
+ :wbr)
+ "The list of HTML tags that should be output as empty tags.
+See *HTML-EMPTY-TAG-AWARE-P*.")
+
+(defvar *html-empty-tag-aware-p* t
+ "Set this to NIL to if you want to use CL-WHO as a strict XML
+generator. Otherwise, CL-WHO will only write empty tags listed
+in *HTML-EMPTY-TAGS* as <tag/> \(XHTML mode) or <tag> \(SGML
+mode). For all other tags, it will always generate
+<tag></tag>.")
+
+(defconstant +newline+ "\n"
+ "Used for indentation.")
+
+(defconstant +spaces+ (format nil "~V@{ ~}" 2000 t)
+ "Used for indentation.")
+
487 site-lisp/xl-who/who.l
@@ -0,0 +1,487 @@
+;;; -*- mode: lisp; package:xl-who; -*-
+;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.36 2008/03/27 23:17:55 edi Exp $
+
+;;; Copyright (c) 2003-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(provide "xl-who/xl-who")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "ansify")
+ (require "xl-who/package")
+ (require "xl-who/specials"))
+
+(in-package :xl-who)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ansify::install))
+
+
+(defmacro n-spaces (n)
+ "A string with N spaces - used by indentation."
+ `(make-vector ,n
+ :element-type 'character
+ :displaced-to +spaces+
+ :displaced-index-offset 0))
+
+(defun html-mode ()
+ "Returns the current HTML mode. :SGML for (SGML-)HTML and
+:XML for XHTML."
+ *html-mode*)
+
+(defun (setf html-mode) (mode)
+ "Sets the output mode to XHTML or \(SGML-)HTML. MODE can be
+:SGML for HTML or :XML for XHTML."
+ (ecase mode
+ ((:sgml)
+ (setf *html-mode* :sgml
+ *empty-tag-end* ">"
+ *prologue* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"))
+ ((:xml)
+ (setf *html-mode* :xml
+ *empty-tag-end* " />"
+ *prologue* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"))))
+
+(declaim (inline escape-char))
+(defun escape-char (char &key (test *escape-char-p*))
+ "Returns an escaped version of the character CHAR if CHAR satisfies
+the predicate TEST. Always returns a string."
+ (if (funcall test char)
+ (case char
+ (#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\' "&#039;")
+ (#\" "&quot;")
+ (t (format nil (if (eq *html-mode* :xml) "&#x~x;" "&#~d;")
+ (ed:char-unicode char))))
+ (make-string 1 :initial-element char)))
+
+(defun escape-string (string &key (test *escape-char-p*))
+ "Escape all characters in STRING which pass TEST. This function is
+not guaranteed to return a fresh string. Note that you can pass NIL
+for STRING which'll just be returned."
+ (let ((first-pos (position-if test string))
+ (format-string (if (eq *html-mode* :xml) "&#x~x;" "&#~d;")))
+ (if (not first-pos)
+ ;; nothing to do, just return STRING
+ string
+ (with-output-to-string (s)
+ (loop with len = (length string)
+ for old-pos = 0 then (1+ pos)
+ for pos = first-pos
+ then (position-if test string :start old-pos)
+ ;; now the characters from OLD-POS to (excluding) POS
+ ;; don't have to be escaped while the next character has to
+ for char = (and pos (char string pos))
+ while pos
+ do (write-sequence string s :start old-pos :end pos)
+ (case char
+ ((#\<)
+ (write-sequence "&lt;" s))
+ ((#\>)
+ (write-sequence "&gt;" s))
+ ((#\&)
+ (write-sequence "&amp;" s))
+ ((#\')
+ (write-sequence "&#039;" s))
+ ((#\")
+ (write-sequence "&quot;" s))
+ (otherwise
+ (format s format-string (ed:char-unicode char))))
+ while (< (1+ pos) len)
+ finally (unless pos
+ (write-sequence string s :start old-pos)))))))
+
+(flet ((minimal-escape-char-p (char) (find char "<>&")))
+ (defun escape-char-minimal (char)
+ "Escapes only #\<, #\>, and #\& characters."
+ (escape-char char :test #'minimal-escape-char-p))
+ (defun escape-string-minimal (string)
+ "Escapes only #\<, #\>, and #\& in STRING."
+ (escape-string string :test #'minimal-escape-char-p)))
+
+(flet ((minimal-plus-quotes-escape-char-p (char) (find char "<>&'\"")))
+ (defun escape-char-minimal-plus-quotes (char)
+ "Like ESCAPE-CHAR-MINIMAL but also escapes quotes."
+ (escape-char char :test #'minimal-plus-quotes-escape-char-p))
+ (defun escape-string-minimal-plus-quotes (string)
+ "Like ESCAPE-STRING-MINIMAL but also escapes quotes."
+ (escape-string string :test #'minimal-plus-quotes-escape-char-p)))
+
+(flet ((iso-8859-1-escape-char-p (char)
+ (or (find char "<>&'\"")
+ (> (ed:char-unicode char) 255))))
+ (defun escape-char-iso-8859-1 (char)
+ "Escapes characters that aren't defined in ISO-8859-9."
+ (escape-char char :test #'iso-8859-1-escape-char-p))
+ (defun escape-string-iso-8859-1 (string)
+ "Escapes all characters in STRING which aren't defined in ISO-8859-1."
+ (escape-string string :test #'iso-8859-1-escape-char-p)))
+
+(defun escape-string-iso-8859 (string)
+ "Identical to ESCAPE-STRING-8859-1. Kept for backward compatibility."
+ (escape-string-iso-8859-1 string))
+
+(flet ((non-7bit-ascii-escape-char-p (char)
+ (or (find char "<>&'\"")
+ (> (ed:char-unicode char) 127))))
+ (defun escape-char-all (char)
+ "Escapes characters which aren't in the 7-bit ASCII character set."
+ (escape-char char :test #'non-7bit-ascii-escape-char-p))
+ (defun escape-string-all (string)
+ "Escapes all characters in STRING which aren't in the 7-bit ASCII
+character set."
+ (escape-string string :test #'non-7bit-ascii-escape-char-p)))
+
+(defun process-tag (sexp body-fn)
+ "Returns a string list corresponding to the `HTML' \(in CL-WHO
+syntax) in SEXP. Uses the generic function CONVERT-TO-STRING-LIST
+internally. Utility function used by TREE-TO-TEMPLATE."
+ (let (tag attr-list body)
+ (cond
+ ((keywordp sexp)
+ (setq tag sexp))
+ ((atom (first sexp))
+ (setq tag (first sexp))
+ ;; collect attribute/value pairs into ATTR-LIST and tag body (if
+ ;; any) into BODY
+ (loop for rest on (cdr sexp) by #'cddr
+ if (keywordp (first rest))
+ collect (cons (first rest) (second rest)) into attr
+ else
+ do (progn (setq attr-list attr)
+ (setq body rest)
+ (return))
+ finally (setq attr-list attr)))
+ ((listp (first sexp))
+ (setq tag (first (first sexp)))
+ (loop for rest on (cdr (first sexp)) by #'cddr
+ if (keywordp (first rest))
+ collect (cons (first rest) (second rest)) into attr
+ finally (setq attr-list attr))
+ (setq body (cdr sexp))))
+ (convert-tag-to-string-list tag attr-list body body-fn)))
+
+(defun convert-attributes (attr-list)
+ "Helper function for CONVERT-TAG-TO-STRING-LIST which converts the
+alist ATTR-LIST of attributes into a list of strings and/or Lisp
+forms."
+ (loop with =var= = (gensym)
+ with attribute-quote = (string *attribute-quote-char*)
+ for (orig-attr . val) in attr-list
+ for attr = (if *downcase-tokens-p*
+ (string-downcase orig-attr)
+ (string orig-attr))
+ unless (null val) ;; no attribute at all if VAL is NIL
+ if (constantp val)
+ if (and (eq *html-mode* :sgml) (eq val t)) ; special case for SGML
+ nconc (list " " attr)
+ else
+ nconc (list " "
+ ;; name of attribute
+ attr
+ (format nil "=~C" *attribute-quote-char*)
+ ;; value of attribute
+ (cond ((stringp val)
+ ;; a string, just use it - this case is
+ ;; actually not necessary because of
+ ;; the last case
+ val)
+ ((eq val t)
+ ;; VAL is T, use attribute's name
+ attr)
+ (t
+ ;; constant form, PRINC it -
+ ;; EVAL is OK here because of CONSTANTP
+ (format nil "~A" (eval val))))
+ attribute-quote)
+ end
+ else
+ ;; do the same things as above but at runtime
+ nconc (list `(let ((,=var= ,val))
+ (cond ((null ,=var=))
+ ((eq ,=var= t)
+ ,(case *html-mode*
+ (:sgml
+ `(htm ,(format nil " ~A" attr)))
+ ;; otherwise default to :xml mode
+ (t
+ `(htm ,(format nil " ~A=~C~A~C"
+ attr
+ *attribute-quote-char*
+ attr
+ *attribute-quote-char*)))))
+ (t
+ (htm ,(format nil " ~A=~C" attr *attribute-quote-char*)
+ (str ,=var=)
+ ,attribute-quote)))))))
+
+(defun convert-tag-to-string-list (tag attr-list body body-fn)
+ "The standard method which is not specialized. The idea is that you
+can use EQL specializers on the first argument."
+ (let ((tag (if *downcase-tokens-p* (string-downcase tag) (string tag))))
+ (nconc
+ (if *indent*
+ ;; indent by *INDENT* spaces
+ (list +newline+ (n-spaces *indent*)))
+ ;; tag name
+ (list "<" tag)
+ ;; attributes
+ (convert-attributes attr-list)
+ ;; body
+ (if body
+ (append
+ (list ">")
+ ;; now hand over the tag's body to TREE-TO-TEMPLATE, increase
+ ;; *INDENT* by 2 if necessary
+ (if *indent*
+ (let ((*indent* (+ 2 *indent*)))
+ (funcall body-fn body))
+ (funcall body-fn body))
+ (if *indent*
+ ;; indentation
+ (list +newline+ (n-spaces *indent*)))
+ ;; closing tag
+ (list "</" tag ">"))
+ ;; no body, so no closing tag unless defined in *HTML-EMPTY-TAGS*
+ (if (or (not *html-empty-tag-aware-p*)
+ (member tag *html-empty-tags* :test #'string-equal))
+ (list *empty-tag-end*)
+ (list ">" "</" tag ">"))))))
+
+(defun apply-to-tree (function test tree)
+ "Apply FUNCTION recursively to all elements of the tree TREE \(not
+only leaves) which pass TEST."
+ (cond
+ ((funcall test tree)
+ (funcall function tree))
+ ((consp tree)
+ (cons
+ (apply-to-tree function test (car tree))
+ (apply-to-tree function test (cdr tree))))
+ (t tree)))
+
+(defun replace-htm (tree transformation)
+ "Replace all subtrees of TREE starting with the symbol HTM with the
+same subtree after TRANSFORMATION has been applied to it. Utility
+function used by TREE-TO-TEMPLATE and TREE-TO-COMMANDS-AUX."
+ (apply-to-tree #'(lambda (element)
+ (cons 'htm (funcall transformation (cdr element))))
+ #'(lambda (element)
+ (and (consp element)
+ (eq (car element) 'htm)))
+ tree))
+
+(defun tree-to-template (tree)
+ "Transforms an HTML tree into an intermediate format - mainly a
+flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX."
+ (loop for element in tree
+ nconc (cond ((or (keywordp element)
+ (and (listp element)
+ (keywordp (first element)))
+ (and (listp element)
+ (listp (first element))
+ (keywordp (first (first element)))))
+ ;; normal tag
+ (process-tag element #'tree-to-template))
+ ((listp element)
+ ;; most likely a normal Lisp form - check if we
+ ;; have nested HTM subtrees
+ (list
+ (replace-htm element #'tree-to-template)))
+ (t
+ (if *indent*
+ (list +newline+ (n-spaces *indent*) element)
+ (list element))))))
+
+(defun string-list-to-string (string-list)
+ "Concatenates a list of strings to one string."
+ ;; note that we can't use APPLY with CONCATENATE here because of
+ ;; CALL-ARGUMENTS-LIMIT
+ (let ((total-size 0))
+ (dolist (string string-list)
+ (incf total-size (length string)))
+ (let ((result-string (make-sequence 'simple-string total-size))
+ (curr-pos 0))
+ (dolist (string string-list)
+ (replace result-string string :start1 curr-pos)
+ (incf curr-pos (length string)))
+ result-string)))
+
+(defun conc (&rest string-list)
+ "Concatenates all arguments which should be string into one string."
+ (funcall #'string-list-to-string string-list))
+
+(defun tree-to-commands-aux (tree stream)
+ "Transforms the intermediate representation of an HTML tree into
+Lisp code to print the HTML to STREAM. Utility function used by
+TREE-TO-COMMANDS."
+ (let ((in-string t)
+ collector
+ string-collector)
+ (flet ((emit-string-collector ()
+ "Generate a WRITE-STRING statement for what is currently
+in STRING-COLLECTOR."
+ (list 'write-string
+ (string-list-to-string (nreverse string-collector))
+ stream))
+ (tree-to-commands-aux-internal (tree)
+ "Same as TREE-TO-COMMANDS-AUX but with closed-over STREAM
+for REPLACE-HTM."
+ (tree-to-commands-aux tree stream)))
+ (unless (listp tree)
+ (return-from tree-to-commands-aux tree))
+ (loop for element in tree
+ do (cond ((and in-string (stringp element))
+ ;; this element is a string and the last one
+ ;; also was (or this is the first element) -
+ ;; collect into STRING-COLLECTOR
+ (push element string-collector))
+ ((stringp element)
+ ;; the last one wasn't a string so we start
+ ;; with an empty STRING-COLLECTOR
+ (setq string-collector (list element)
+ in-string t))
+ (string-collector
+ ;; not a string but STRING-COLLECTOR isn't
+ ;; empty so we have to emit the collected
+ ;; strings first
+ (push (emit-string-collector) collector)
+ (setq in-string nil
+ string-collector '())
+ ;; collect this element but walk down the
+ ;; subtree first
+ (push (replace-htm element #'tree-to-commands-aux-internal)
+ collector))
+ (t
+ ;; not a string and empty STRING-COLLECTOR
+ (push (replace-htm element #'tree-to-commands-aux-internal)
+ collector)))
+ finally (return (if string-collector
+ ;; finally empty STRING-COLLECTOR if
+ ;; there's something in it
+ (nreverse (cons (emit-string-collector)
+ collector))
+ (nreverse collector)))))))
+
+(defun tree-to-commands (tree stream &optional prologue)
+ "Transforms an HTML tree into code to print the HTML to STREAM."
+ ;; use TREE-TO-TEMPLATE, then TREE-TO-COMMANDS-AUX, and finally
+ ;; replace the special symbols ESC, STR, FMT, and HTM
+ (apply-to-tree #'(lambda (x)
+ (case (first x)
+ ((esc)
+ ;; (ESC form ...)
+ ;; --> (LET ((RESULT form))
+ ;; (WHEN RESULT
+ ;; (WRITE-STRING (ESCAPE-STRING RESULT STREAM))))
+ (let ((result (gensym)))
+ `(let ((,result ,(second x)))
+ (when ,result (write-string (escape-string ,result) ,stream)))))
+ ((str)
+ ;; (STR form ...)
+ ;; --> (LET ((RESULT form))
+ ;; (WHEN RESULT (PRINC RESULT STREAM)))
+ (let ((result (gensym)))
+ `(let ((,result ,(second x)))
+ (when ,result (princ ,result ,stream)))))
+ ((fmt)
+ ;; (FMT form*) --> (FORMAT STREAM form*)
+ (list* 'format stream (rest x)))))
+ #'(lambda (x)
+ (and (consp x)
+ (member (first x)
+ '(esc str fmt)
+ :test #'eq)))
+ ;; wrap PROGN around the HTM forms
+ (apply-to-tree (constantly 'progn)
+ #'(lambda (x)
+ (and (atom x)
+ (eq x 'htm)))
+ (tree-to-commands-aux
+ (if prologue
+ (list* 'htm prologue +newline+
+ (tree-to-template tree))
+ (cons 'htm (tree-to-template tree)))
+ stream))))
+
+(defmacro with-html-output ((var &optional stream
+ &key prologue
+ ((:indent *indent*) *indent*))
+ &body body)
+ "Transform the enclosed BODY consisting of HTML as s-expressions
+into Lisp code to write the corresponding HTML as strings to VAR -
+which should either hold a stream or which'll be bound to STREAM if
+supplied."
+ (when (and *indent*
+ (not (integerp *indent*)))
+ (setq *indent* 0))
+ (when (eq prologue t)
+ (setq prologue *prologue*))
+ `(let ((,var ,(or stream var)))
+ ,(tree-to-commands body var prologue)))
+
+(defmacro with-html-output-to-string ((var &optional string-form
+ &key (element-type ''character)
+ prologue
+ indent)
+ &body body)
+ "Transform the enclosed BODY consisting of HTML as s-expressions
+into Lisp code which creates the corresponding HTML as a string."
+ `(with-output-to-string (,var ,string-form
+ #-(or :ecl :cmu :sbcl) :element-type
+ #-(or :ecl :cmu :sbcl) ,element-type)
+ (with-html-output (,var nil :prologue ,prologue :indent ,indent)
+ ,@body)))
+
+(defmacro show-html-expansion ((var &optional stream
+ &key prologue
+ ((:indent *indent*) *indent*))
+ &body body)
+ "Show the macro expansion of WITH-HTML-OUTPUT."
+ (when (and *indent*
+ (not (integerp *indent*)))
+ (setq *indent* 0))
+ (when (eq prologue t)
+ (setq prologue *prologue*))
+ `(pprint '(let ((,var ,(or stream var)))
+ ,(tree-to-commands body var prologue))))
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+;; also used by LW-ADD-ONS
+
+(defvar *hyperdoc-base-uri* "http://weitz.de/cl-who/")
+
+(defun hyperdoc-lookup (symbol type)
+ (multiple-value-bind (sym status)
+ (find-symbol (symbol-name symbol) :xl-who)
+ (when (and sym (eq status :external))
+ (ed:shell-execute
+ (format nil "~A#~(~A~)" *hyperdoc-base-uri* symbol)
+ t))))
+
51 test/test.l
@@ -0,0 +1,51 @@
+;;; -*- mode:lisp; package:xl-who.test; -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "xl-who"))
+
+(defpackage :xl-who.test
+ (:use :lisp :xl-who))
+
+(in-package :xl-who.test)
+
+(defvar *htmlfile*
+ (merge-pathnames "test.html"
+ (directory-namestring (ed:get-buffer-file-name))))
+
+(with-open-file (out *htmlfile* :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create
+ :encoding :binary)
+ (with-html-output (*standard-output* out :indent t)
+ (:html
+ (:body
+ (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+ ("http://marcusmiller.com/" . "Marcus Miller")
+ ("http://www.milesdavis.com/" . "Miles Davis"))
+ do (htm (:a :href link
+ (:b (str title)))
+ :br))
+ (:hr)
+ (:table :border 0 :cellpadding 4
+ (loop for i below 25 by 5
+ do (htm
+ (:tr :align "right"
+ (loop for j from i below (+ i 5)
+ do (htm
+ (:td :bgcolor (if (oddp j)
+ "pink"
+ "green")
+ (fmt "~@R" (1+ j)))))))))
+ (:hr)
+ (:h4 "Look at the character entities generated by this example")
+ (loop for i from 0
+ for string in '("Fête" "Sørensen" "naïve" "Hühner" "Straße")
+ do (htm
+ (:p :style (conc "background-color:" (case (mod i 3)
+ ((0) "red")
+ ((1) "orange")
+ ((2) "blue")))
+ (htm (esc string)))))))))
+
+
+(ed:shell-execute *htmlfile* t)

0 comments on commit c5bd53b

Please sign in to comment.