diff --git a/src/flute.lisp b/src/flute.lisp index 780b898..5db3cf0 100644 --- a/src/flute.lisp +++ b/src/flute.lisp @@ -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) diff --git a/src/package.lisp b/src/package.lisp index 60e5c92..d400e6f 100644 --- a/src/package.lisp +++ b/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 diff --git a/src/util.lisp b/src/util.lisp index 5a5022c..7ae460c 100644 --- a/src/util.lisp +++ b/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)) - (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) diff --git a/t/flute.lisp b/t/flute.lisp index 8c4cea9..1e5bb35 100644 --- a/t/flute.lisp +++ b/t/flute.lisp @@ -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
&" + (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-"-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 <br> &" (second (element-children a)))) + (is (string= "child'<>".html" (attr (element-attrs (third (element-children a))) :href))) + (is (string= "child'<>\"" (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 <br> &" (second (element-children a)))) + (is (string= "child'<>".html" (attr (element-attrs (third (element-children a))) :href))) + (is (string= "child'<>\"" (first (element-children (third (element-children a)))))) + (is (string= "€" (second (element-children (third (element-children a)))))) + (is (string= "€" (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))