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 "&lt;" 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 "&gt;" 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