01 ;;; -*- Lisp -*- mode
02
03 (in-package #:com.paskvil.uhttp)
04
05 (defun str-replace (str tr-rules)
06 (with-output-to-string (new-str)
07 (let (tr)
08 (loop for c across str
09 do (if (setf tr (assoc c tr-rules))
10 (write-string (cdr tr) new-str)
11 (write-char c new-str))))))
12
13 (defun escape-html-chars (str)
14 (with-output-to-string (new-str)
15 (let ((pos1 0)
16 (pos2 -1))
17 (loop for c across str
18 do (case c
19 (#\< (when (<= pos1 pos2)
20 (write-string (subseq str pos1 (1+ pos2)) new-str))
21 (write-string "<" new-str)
22 (setf pos1 (+ pos2 2))
23 (incf pos2))
24 (#\> (when (<= pos1 pos2)
25 (write-string (subseq str pos1 (1+ pos2)) new-str))
26 (write-string ">" new-str)
27 (setf pos1 (+ pos2 2))
28 (incf pos2))
29 (t (incf pos2))))
30 (when (<= pos1 pos2)
31 (write-string (subseq str pos1 (1+ pos2)) new-str)))))
32
33 (defparameter *html-tags*
34 '(:a :applet :area :b :big :blockquote :body :br :button
35 :caption :center :code :dd :del :div :em :font :form :frame
36 :h1 :h2 :h3 :h4 :h5 :h6 :head :hr :html :i :iframe :img :input
37 :labe :li :map :meta :noscript :object :ol :option
38 :p :param :pre :s :script :select :small :span :strike
39 :strong :style :sub :sup :table :tbody :td :textarea :tfoot
40 :th :thead :title :tr :tt :u :ul :var))
41 (defparameter *html-single-tags*
42 '(:a :area :br :frame :hr :img :input :meta :param))
43
44 (defun to-html-string (obj)
45 (escape-html-chars (format nil "~a" obj)))
46
47 (defmacro html (forms)
48 "Emits HTML code based on provided forms.
49
50 If the form starts with a keyword that denotes HTML tag,
51 appropriate HTML code is printed to *html-stream* stream.
52 If it's any other designator, the whole form is considered
53 to be a form to execute, potentially containing more html.
54
55 Example usage:
56
57 (html (:p \"hello\"))
58 (html ((:p :style \"font-size: 12px;\") \"hello\"))
59 (html (:img :src \"/images/img.jpg\"))
60 (html (:body (:ul (dotimes (x 10) (html (:li x)))))"
61 (labels ((is-html-tag (tag) (find tag *html-tags*))
62 (is-html-single-tag (tag) (find tag *html-single-tags*)))
63 (cond ((atom forms) ; atom - presume it's contents to print
64 `(format t "~a" (to-html-string ,forms)))
65 ((and forms (listp forms)) ; list - either tag definition, or code
66 (let ((fhead (car forms))
67 (ftail (cdr forms)))
68 (cond ((and (listp fhead) ; starts with list - should be tag with attributes
69 (keywordp (car fhead))
70 (is-html-tag (car fhead)))
71 `(progn
72 (format t "<~a" (car ',fhead))
73 ,@(do ((res '())
74 (att (cdr fhead) (cddr att)))
75 ((null att) (nreverse res))
76 (push `(format t " ~a='~a'" (car ',att) (to-html-string (cadr ',att))) res))
77 (format t ">")
78 ,@(loop for x in ftail collecting `(html ,x))
79 (format t "</~a>~%" (car ',fhead))))
80 ((and (atom fhead) ; single tag - followed by attributes
81 (keywordp fhead)
82 (is-html-single-tag fhead))
83 `(progn
84 (format t "<~a" ,fhead)
85 ,@(do ((res '())
86 (att ftail (cddr att)))
87 ((null att) (nreverse res))
88 (push `(format t " ~a='~a'" (car ',att) (to-html-string (cadr ',att))) res))
89 (format t "/>~%")))
90 ((and (atom fhead) ; normal tag, followed by contents
91 (keywordp fhead)
92 (is-html-tag fhead))
93 `(progn
94 (format t "<~a>" ,fhead)
95 ,@(loop for x in ftail collecting `(html ,x))
96 (format t "</~a>~%" ,fhead)))
97 (t ; presume it's a code to execute
98 forms)))))))
99
© 2011 Josef Nygrin - paskvil.com