;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(declaim (optimize (speed 0) (safety 3) (debug 3)))
;; Lifted directly from araneida.
(in-package :dns-admin)
;;; XXX fix this, it's not correct
(defun html-reserved-p (c)
(member c '(#\< #\" #\> #\&)))
(defun html-escape (html-string)
(apply #'concatenate 'string
(loop for c across html-string
if (html-reserved-p c)
collect (format nil "&#~A;" (char-code c))
else if (eql c #\Newline) collect "
"
else collect (string c))))
(defun s. (&rest args)
"Concatenate ARGS as strings"
(declare (optimize (speed 3)))
(let ((*print-pretty* nil))
(with-output-to-string (out)
(dolist (arg args)
(princ arg out)))))
(defun html-escape-tag (tag attrs content)
(declare (ignore tag attrs))
(s. (mapcar #'html-escape content)))
(setf (get 'escape 'html-converter) #'html-escape-tag)
(setf (get 'null 'html-converter) #'princ-to-string)
(macrolet ((html-attr-body ()
`(with-output-to-string (o)
(loop for (att val . rest) on attr by #'cddr do
(cond
((symbolp att)
(progn
(princ " " o)
(princ (symbol-name att) o)
(princ "=\"" o)
(princ (val-printer val) o)
(princ "\"" o)))
(t
(error "attribute ~S is not a symbol in attribute list ~S" att attr)))))))
(defun html-attr (attr)
(macrolet ((val-printer (val)
val))
(html-attr-body)))
(defun html-attr-escaped (attr)
(macrolet ((val-printer (val)
`(html-escape ,val)))
(html-attr-body))))
(defun empty-element-p (tag)
(member (intern (symbol-name tag) #.*package*) '()))
(defmacro defhtmltag (tag (attributes-var content-var) &body body)
"Define a custom HTML tag
Useful for custom phrases, or even special constructs.
Example:
(defhtmltag coffee (attr content)
(declare (ignore attr content))
\"c|_|\")
So, saying
(span \"Nice hot \" (coffee))
Would produce:
Nice hot c|_|
More in-depth use would be something such as:
(even-odd-list
(li \"one\")
(li \"two\")
(li \"three\"))
Turning into:
(ul
((li :class \"odd\") \"one\")
((li :class \"even\") \"two\")
((li :class \"odd\") \"odd\"))
Your custom tag is expected to return either a string or
an html construct like you'd pass to HTML-STREAM."
(with-gensyms (throw-away)
`(setf (get ',tag :html-converter)
(lambda (,throw-away ,attributes-var ,content-var)
(declare (ignore ,throw-away))
(funcall
(lambda (,attributes-var ,content-var)
,@body)
,attributes-var ,content-var)))))
(defun htmlp (html)
"Returns t if html is a legal HTML list.
NB: HTML and friends print out a superset of legal html lists.
'(ul (li \"yes\") (li \"no\")) is legal
3 is not
But HTML will print both of them"
(and (consp html)
(not (stringp (car html)))))
(defmacro destructure-html ((tag-sym attrs-sym content-sym) html &body body)
"Destructure an HTML construct.
(destructure-html (tag attrs content) '((span :class \"strange\") \"A strange span!\")
(format t \"<~A ~{~A~}>~{~A~}\" tag attrs content tag))
If the construct is invalid, it will cause an error"
(once-only (html)
`(if (htmlp ,html)
(let ((,tag-sym (if (consp (car ,html))
(caar ,html)
(car ,html)))
(,attrs-sym (if (consp (car ,html))
(cdar ,html)
nil))
(,content-sym (cdr ,html)))
,@body))))
; I admit, this is a rather goofy way to write this. There's just so much code they have in common
; and this lets me modify them rather easily.
(macrolet ((html-body ()
`(ret-block
(cond ((htmlp things)
(destructure-html (tag attrs content) things
(let ((special-effect (get tag :html-converter)))
(if special-effect
(if (not (functionp special-effect))
(error "Tag ~A has :html-converter set, but NOT as a function." tag)
(call-self stream (funcall special-effect tag attrs content) inline-elements))
(cond ((equal (symbol-name 'comment) (symbol-name tag))
(printing
(format-out "~%")))
((not (empty-element-p tag))
(printing
(format-out "<~A~A>" (symbol-name tag) (attr-printer attrs))
(iter-list (c content)
(call-self stream c inline-elements))
(format-out "~:[~;~%~]"
(symbol-name tag)
(not (member tag inline-elements)))))
(t
(format-out "<~A~A>" (symbol-name tag) (attr-printer attrs))))))))
((consp things)
(iter-list (thing things) (format-out "~A" thing)))
((functionp things)
(call-function things stream))
((keywordp things)
(format-out "<~A>" (symbol-name things)))
(t
(format-out "~A" (thing-printer things)))))))
;; stream forms first
(macrolet ((ret-block (output-block)
`(progn
,output-block
t))
(iter-list ((item list) func)
`(dolist (,item ,list)
,func))
(printing (&body list)
`(progn
,@list))
(format-out (&rest args)
`(format stream ,@args))
(call-function (things stream)
`(funcall ,things ,stream)))
(defun html-stream (stream things &optional inline-elements)
"Format supplied argument as HTML. Argument may be a string
\(returned unchanged\) or a list of \(tag content\) where tag may be
\(tagname attrs\). \(\(a :href \"/ \"\) \"home\"\) is formatted as
you'd expect it to be. INLINE-ELEMENTS is a list of elements not to
print a newline after. Returns T unless broken, so can be the last
form in a handler For special effects, set the HTML-CONVERTER property
of a symbol for a tag to a function. It will be called with arguments
\(TAG ATTRS CONTENT\) and should return a string to be interpolated at
that point."
(declare (optimize (speed 3))
(type stream stream))
(macrolet ((attr-printer (attrs)
`(html-attr ,attrs))
(call-self (stream things &optional inline-elements)
`(html-stream ,stream ,things ,inline-elements))
(thing-printer (things)
`(princ-to-string things)))
(html-body)))
(defun html-escaped-stream (stream things &optional inline-elements)
"Format supplied argument as HTML, escaping properly.
Just like html-stream except certain things are now html-escaped.
Content - in '\(p \"foo\"\) \"foo\" is the content - is escaped, as
well as the values of attributes. Please note that this CAN result in
double escaping if calling code also escapes. For special effects,
set the HTML-CONVERTER property of a symbol for a tag to a function.
It will be called with arguments \(TAG ATTRS CONTENT\) and should
return a string to be interpolated at that point. NB that the attrs
and content will be passed in *unescaped*"
(declare (optimize (speed 3))
(type stream stream))
(macrolet ((attr-printer (attrs)
`(html-attr-escaped ,attrs))
(call-self (stream things &optional inline-elements)
`(html-escaped-stream ,stream ,things ,inline-elements))
(thing-printer (things)
`(html-escape (princ-to-string ,things))))
(html-body))))
;; now for the string forms
(macrolet ((ret-block (output-block)
output-block)
(iter-list ((item list) func)
`(apply #'concatenate 'string (mapcar (lambda (,item) ,func) ,list)))
(printing (&body list)
`(concatenate 'string
,@list))
(format-out (&rest args)
`(format nil ,@args))
(call-function (things stream)
(declare (ignore stream))
`(funcall ,things)))
(defun html (things &optional inline-elements)
"Format supplied argument as HTML. Argument may be a string
\(returned unchanged\) or a list of \(tag content\) where tag may be
\(tagname attrs\). \(\(a :href \"/\"\) \"home\"\) is formatted as
you'd expect it to be. For special effects, set the HTML-CONVERTER
property of a symbol for a tag to a function. It will be called with
arguments \(TAG ATTRS CONTENT\) and should return a string to be
interpolated at that point."
(declare (optimize (speed 3)))
(macrolet ((attr-printer (attrs)
`(html-attr ,attrs))
(call-self (stream things &optional inline-elements)
`(html ,things ,inline-elements))
(thing-printer (things)
`(princ-to-string ,things)))
(html-body)))))
(defun html5 (things &optional inline-elements)
(format nil "~%~a" (html things inline-elements)))
#||
(search-html-tree '((string> ht :element) t (= p :element)) '((html) ((body) ((p) "foo") ((p) "bar") ((div :title "titl") "blah"))))
||#
(defun search-html-tree (search-terms tree)
(labels ((node-matches (term tree)
(or (eql term t)
(destructuring-bind (op content name) term
(let ((r-op (if (eql op '=) 'equal op)))
(if (eql name :element)
(funcall r-op content (caar tree))
(funcall r-op content (getf (cdar tree) name))))))))
(cond ((eql (cdr search-terms) nil)
(and (node-matches (car search-terms) tree) tree))
((null tree) nil)
((node-matches (car search-terms) tree)
(remove-if #'null
(mapcar (lambda (tr)
(search-html-tree (cdr search-terms) tr))
(cdr tree)))))))