test for builtin element structure, user element structure, escape html

src/flute.lisp

@@ -15,8 +15,8 @@
            :accessor element-prefix)))
 
 (defclass user-element (element)
-  ((expand-to :initarg :expand-to
+  ((expand-to :initarg :expander
-              :accessor user-element-expand-to)))
+              :accessor user-element-expander)))
 
 (defun make-builtin-element (&key tag attrs children)
   (make-instance 'builtin-element :tag tag :attrs attrs
@@ -26,10 +26,16 @@
   (make-instance 'builtin-element-with-prefix :tag tag :attrs attrs :prefix prefix
                  :children (escape-children children)))
 
-(defun make-user-element (&rest args &key tag attrs children expand-to)
+(defun make-user-element (&rest args &key tag attrs children expander)
-  (make-instance 'user-element :tag tag :attrs attrs :expand-to expand-to
+  (make-instance 'user-element :tag tag :attrs attrs :expander expander
                  :children (escape-children children)))
 
+(defmethod user-element-expand-to ((element user-element))
+  (funcall (user-element-expander element)
+           (element-tag element)
+           (element-attrs element)
+           (element-children element)))
+
 (defstruct (attrs (:constructor %make-attrs))
   alist)
 
@@ -50,7 +56,7 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
       (%make-attrs :alist alist)))
 
 (defmethod (setf attr) (value (attrs attrs) key)
-  (setf (aget (attrs-alist) key) value))
+  (setf (aget (attrs-alist attrs) key) value))
 
 (defmethod delete-attr ((attrs attrs) key)
   (delete-from-alistf (attrs-alist attrs) key))
@@ -65,7 +71,7 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
   (delete-attr (element-attrs element) key))
 
 (defmethod attr ((element element) key)
-  (attr (element-attrs element)))
+  (attr (element-attrs element) key))
 
 (defvar *builtin-elements* (make-hash-table))
 
@@ -132,7 +138,7 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
                      args)
          (make-user-element :tag (string-downcase ',name) :attrs ,g!attrs
                             :children ,g!children
-                            :expand-to
+                            :expander
                             (lambda (tag attrs children)
                               (declare (ignorable tag attrs children))
                               (progn ,@body)))))))
@@ -141,11 +147,7 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
 
 (defmethod print-object ((element user-element) stream)
   (if *expand-user-element*
-      (print-object (funcall (user-element-expand-to element)
+      (print-object (user-element-expand-to element) stream)
-                             (element-tag element)
-                             (element-attrs element)
-                             (element-children element))
-                    stream)
       (call-next-method)))
 
 (defmacro h (&body body)

src/package.lisp

@@ -23,6 +23,9 @@
    ;;; user define elements
    :define-element
    :*expand-user-element*
+   ;; for reference tag name and children elements in user element definition
+   :tag
+   :children
 
    ;;; attribute accessing utilility
    :attrs

src/util.lisp

@@ -50,10 +50,12 @@
     (t (format nil "&#~d;" (char-code char)))))
 
 (defun escape-string (string &optional (test #'utf8-html-escape-char-p))
+  (if (stringp string)
       (with-output-to-string (s)
         (loop
            for c across string
-       do (write (if (funcall test c) (escape-char c) c) :stream s :escape nil))))
+           do (write (if (funcall test c) (escape-char c) c) :stream s :escape nil)))
+      string))
 
 (defun escape-attrs-alist (alist)
   (mapcar (lambda (kv)

t/flute.lisp

@@ -3,8 +3,12 @@
   (:use :cl :flute :fiveam))
 (in-package :flute.test)
 
-(def-suite simple-builtin-element)
+(def-suite builtin-element)
-(in-suite simple-builtin-element)
+(def-suite escape)
+(def-suite attr-access)
+(def-suite user-element)
+
+(in-suite builtin-element)
 
 (test empty-attr
   (let* ((div1 (div))
@@ -107,12 +111,130 @@
     (is (equal '((:id . "dog") (:class . "happy")) (attrs-alist (element-attrs div4))))
     (is (equal (list div1 div2 div3) (element-children div4)))))
 
+(in-suite escape)
 
+(defparameter *a-attrs*
+  '((:id . "nothing-to-escape")
+    (:class . "something-with-\"-in-value")
+    (:href . "http://localhost:3000/id=3&name=foo")
+    (:data . "'<>")))
+
+(defun new-a ()
+  (a *a-attrs*
+     "child text 1"
+     "child text 2 <br> &"
+     (a :href "child'<>\".html" "child'<>\"" (string (code-char 128)))
+     (string (code-char 128))))
+
+(test escape-attr
+  (let ((escaped-attrs-alist '((:id . "nothing-to-escape")
+                               (:class . "something-with-&quot;-in-value")
+                               (:href . "http://localhost:3000/id=3&name=foo")
+                               (:data . "'<>")) ))
+    (is (equal escaped-attrs-alist (attrs-alist (element-attrs (new-a)))))
+    (let ((*escape-html* nil))
+      (is (equal *a-attrs* (attrs-alist (element-attrs (new-a))))))
+    (let ((*escape-html* :attr))
+      (is (equal escaped-attrs-alist (attrs-alist (element-attrs (new-a))))))
+    (let ((*escape-html* :ascii))
+      (is (equal escaped-attrs-alist (attrs-alist (element-attrs (new-a))))))))
+
+(test escape-children
+  (let ((a (new-a)))
+    (is (string= "child text 1" (first (element-children a))))
+    (is (string= "child text 2 &lt;br&gt; &amp;" (second (element-children a))))
+    (is (string= "child'<>&quot;.html" (attr (element-attrs (third (element-children a))) :href)))
+    (is (string= "child'&lt;&gt;\"" (first (element-children (third (element-children a))))))
+    (is (string= (string (code-char 128)) (second (element-children (third (element-children a))))))
+    (is (string= (string (code-char 128)) (fourth (element-children a)))))
+  (let* ((*escape-html* :ascii)
+         (a (new-a)))
+    (is (string= "child text 1" (first (element-children a))))
+    (is (string= "child text 2 &lt;br&gt; &amp;" (second (element-children a))))
+    (is (string= "child'<>&quot;.html" (attr (element-attrs (third (element-children a))) :href)))
+    (is (string= "child'&lt;&gt;\"" (first (element-children (third (element-children a))))))
+    (is (string= "&#128;" (second (element-children (third (element-children a))))))
+    (is (string= "&#128;" (fourth (element-children a))))))
+
+(in-suite attr-access)
+
+(test attr-get
+  (is (eql nil (attr (a) :id)))
+  (is (eql nil (attr (new-a) :foo)))
+  (is (equal "nothing-to-escape" (attr (new-a) :id)))
+  (is (equal "'<>" (attr (element-attrs (new-a)) :data))))
+
+(test attr-set
+  (let ((a (new-a)))
+    (setf (attr a :id) "a")
+    (setf (attr a :foo) "b")
+    (setf (attr (element-attrs a) :class) "c")
+    (setf (attr (element-attrs a) :bar) "d")
+    (is (equal "a" (attr a :id)))
+    (is (equal "b" (attr a :foo)))
+    (is (equal "c" (attr a :class)))
+    (is (equal "d" (attr a :bar)))))
+
+(test attr-delete
+  (let ((a (new-a)))
+    (delete-attr a :id)
+    (delete-attr a :foo)
+    (delete-attr a :class)
+    (delete-attr (element-attrs a) :bar)
+    (delete-attr a :href)
+    (is (equal '((:data . "'<>")) (attrs-alist (element-attrs a))))))
+
+(in-suite user-element)
+
+(define-element cat ()
+  (div :id "cat"
+       (img :src "cat.png")
+       "I'm a cat"))
+
+(test user-element-simple
+  (let ((cat (cat)))
+    (is (string= "cat" (attr (user-element-expand-to cat) :id)))
+    (is (string= "cat.png" (attr (first (element-children (user-element-expand-to cat))) :src)))
+    (is (string= "I'm a cat" (car (last (element-children (user-element-expand-to cat))))))))
+
+(define-element dog (id size)
+  (if (and (realp size) (> size 10))
+      (div :id id :class "big-dog"
+       children
+       "dog")
+      (div :id id :class "small-dog"
+       children
+       "dog")))
+
+(test user-element-with-attrs
+  (let ((dog1 (dog))
+        (dog2 (dog :size 15))
+        (dog3 (dog (img :src "dog.png")))
+        (dog4 (dog :id "dog" :size 10 (img :src "dog4.png") "woo")))
+    (is (eql nil (attrs-alist (element-attrs dog1))))
+    (is (string= "dog" (first (element-children (user-element-expand-to dog1)))))
+    (is (string= "small-dog" (attr (user-element-expand-to dog1) :class)))
+    (is (eql nil (element-children dog1)))
+    (is (string= "dog" (element-tag dog1)))
+
+    (is (equal '((:size . 15)) (attrs-alist (element-attrs dog2))))
+    (is (equal '((:class . "big-dog")) (attrs-alist (element-attrs (user-element-expand-to dog2)))))
+    (is (string= "dog" (first (element-children (user-element-expand-to dog2)))))
+    (is (eql nil (element-children dog2)))
+
+    (is (eql nil (attrs-alist (element-attrs dog3))))
+    (is (string= "dog" (second (element-children (user-element-expand-to dog3)))))
+    (is (string= "dog.png" (attr (first (element-children (user-element-expand-to dog3))) :src)))
+    (is (string= "dog.png" (attr (first (element-children dog3)) :src)))
+
+    (is (equal '((:id . "dog") (:size . 10)) (attrs-alist (element-attrs dog4))))
+    (is (= 10 (attr dog4 :size)))
+    (is (string= "img" (element-tag (first (element-children dog4)))))
+    (is (string= "dog4.png" (attr (first (element-children (user-element-expand-to dog4))) :src)))
+    (is (string= "woo" (second (element-children dog4))))
+
+    (setf (attr dog4 :size) 16)
+    (is (= 16 (attr dog4 :size)))
+    (is (string= "big-dog" (attr (user-element-expand-to dog4) :class)))))
 
 (run-all-tests)
-
-;; (define-element clock (id size)
-;;   (div :id id
-;;        (h1 "clock")
-;;        (img "blabal" :size size)
-;;        children))