paku/hsx
1
0
Fork 0
Code Issues Pull requests Projects Releases 1 Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Bo Yao 2018-06-30 17:32:09 -04:00
parent dcf21a65be
commit 24ace4da05
4 changed files with 153 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
src/flute.lisp
View file

@ -15,8 +15,8 @@
:accessor element-prefix)))
(defclass user-element (element)
((expand-to :initarg :expand-to
:accessor user-element-expand-to)))
((expand-to :initarg :expander
: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)
(make-instance 'user-element :tag tag :attrs attrs :expand-to expand-to
(defun make-user-element (&rest args &key tag attrs children expander)
(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)
(element-tag element)
(element-attrs element)
(element-children element))
stream)
(print-object (user-element-expand-to element) stream)
(call-next-method)))
(defmacro h (&body body)

3
src/package.lisp
View file

@ -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

10
src/util.lisp
View file

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

138
t/flute.lisp
View file

@ -3,8 +3,12 @@
(:use :cl :flute :fiveam))
(in-package :flute.test)
(def-suite simple-builtin-element)
(in-suite simple-builtin-element)
(def-suite 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))