diff options
Diffstat (limited to 'who.lisp')
| -rw-r--r-- | who.lisp | 370 |
1 files changed, 93 insertions, 277 deletions
@@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.35 2007/08/24 08:01:37 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.42 2009/01/26 11:10:49 edi Exp $ -;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2003-2009, 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 @@ -29,15 +29,8 @@ (in-package :cl-who) -(defmacro n-spaces (n) - "A string with N spaces - used by indentation." - `(make-array ,n - :element-type 'base-char - :displaced-to +spaces+ - :displaced-index-offset 0)) - (defun html-mode () - "Returns the current HTML mode. :SGML for (SGML-)HTML and + "Returns the current HTML mode. :SGML for \(SGML-)HTML and :XML for XHTML." *html-mode*) @@ -54,100 +47,6 @@ *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*)) - (declare (optimize speed)) - "Returns an escaped version of the character CHAR if CHAR satisfies -the predicate TEST. Always returns a string." - (if (funcall test char) - (case char - (#\< "<") - (#\> ">") - (#\& "&") - (#\' "'") - (#\" """) - (t (format nil (if (eq *html-mode* :xml) "&#x~x;" "&#~d;") - (char-code char)))) - (make-string 1 :initial-element char))) - -(defun escape-string (string &key (test *escape-char-p*)) - (declare (optimize speed)) - "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 "<" s)) - ((#\>) - (write-sequence ">" s)) - ((#\&) - (write-sequence "&" s)) - ((#\') - (write-sequence "'" s)) - ((#\") - (write-sequence """ s)) - (otherwise - (format s format-string (char-code 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 "<>&'\"") - (> (char-code 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 "<>&'\"") - (> (char-code 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) (declare (optimize speed space)) "Returns a string list corresponding to the `HTML' \(in CL-WHO @@ -184,7 +83,6 @@ alist ATTR-LIST of attributes into a list of strings and/or Lisp forms." (declare (optimize speed space)) (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) @@ -199,19 +97,14 @@ forms." 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) + (cond ((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) + (string *attribute-quote-char*)) end else ;; do the same things as above but at runtime @@ -219,19 +112,21 @@ forms." (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*))))) + (:sgml + `(fmt " ~A" attr)) + ;; otherwise default to :xml mode + (t + `(fmt " ~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))))))) + (fmt " ~A=~C~A~C" + ,attr + *attribute-quote-char* + ,=var= + *attribute-quote-char*))))))) (defgeneric convert-tag-to-string-list (tag attr-list body body-fn) (:documentation "Used by PROCESS-TAG to convert `HTML' into a list @@ -275,53 +170,21 @@ can use EQL specializers on the first argument." (list *empty-tag-end*) (list ">" "</" tag ">")))))) -(defun apply-to-tree (function test tree) - (declare (optimize speed space)) - (declare (type function function test)) - "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) - (declare (optimize speed space)) - "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)))))) + when (or (keywordp element) + (and (listp element) + (keywordp (first element))) + (and (listp element) + (listp (first element)) + (keywordp (first (first element))))) + ;; the syntax for a tag - process it + nconc (process-tag element #'tree-to-template) + else + ;; something else - insert verbatim + collect element)) (defun string-list-to-string (string-list) (declare (optimize speed space)) @@ -331,7 +194,9 @@ flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX." (let ((total-size 0)) (dolist (string string-list) (incf total-size (length string))) - (let ((result-string (make-sequence 'simple-string total-size)) + (let ((result-string (make-string total-size + #+:lispworks #+:lispworks + :element-type 'lw:simple-char)) (curr-pos 0)) (dolist (string string-list) (replace result-string string :start1 curr-pos) @@ -342,119 +207,83 @@ flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX." "Concatenates all arguments which should be string into one string." (funcall #'string-list-to-string string-list)) -(defun tree-to-commands-aux (tree stream) +(defun tree-to-commands (tree stream &key prologue ((:indent *indent*) *indent*)) (declare (optimize speed space)) - "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) + (when (and *indent* + (not (integerp *indent*))) + (setq *indent* 0)) + (let ((in-string-p t) collector - string-collector) + string-collector + (template (tree-to-template tree))) + (when prologue + (push +newline+ template) + (when (eq prologue t) + (setq prologue *prologue*)) + (push prologue template)) (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) - (declare (optimize speed space)) - "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)))) + stream))) + (dolist (element template) + (cond ((and in-string-p (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-p 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-p nil + string-collector '()) + (push element collector)) + (t + ;; not a string and empty STRING-COLLECTOR + (push element collector)))) + (if string-collector + ;; finally empty STRING-COLLECTOR if + ;; there's something in it + (nreverse (cons (emit-string-collector) + collector)) + (nreverse collector))))) (defmacro with-html-output ((var &optional stream - &key prologue - ((:indent *indent*) *indent*)) + &rest rest + &key prologue 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*)) + (declare (ignore prologue)) `(let ((,var ,(or stream var))) - ,(tree-to-commands body var prologue))) + (macrolet ((htm (&body body) + `(with-html-output (,',var nil :prologue nil :indent ,,indent) + ,@body)) + (fmt (&rest args) + `(format ,',var ,@args)) + (esc (thing) + (with-unique-names (result) + `(let ((,result ,thing)) + (when ,result (write-string (escape-string ,result) ,',var))))) + (str (thing) + (with-unique-names (result) + `(let ((,result ,thing)) + (when ,result (princ ,result ,',var)))))) + ,@(apply 'tree-to-commands body var rest)))) (defmacro with-html-output-to-string ((var &optional string-form - &key (element-type ''character) + &key (element-type #-:lispworks ''character + #+:lispworks ''lw:simple-char) prologue indent) &body body) @@ -466,19 +295,6 @@ into Lisp code which creates the corresponding HTML as a string." (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> |