From ce18d73fa1f1907ae8c9d7cc245537fa9dd25e20 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 29 May 2023 07:28:50 -0700 Subject: Fix another attribute bug: all tests work. * simple.tl: Translate and enable all tests. * who.tl (process-tag): Fix double nreverse bug causing attr list to be truncated to one tag. --- test/simple.tl | 219 ++++++++++++++++++++++++++++++++++++--------------------- who.tl | 3 +- 2 files changed, 138 insertions(+), 84 deletions(-) diff --git a/test/simple.tl b/test/simple.tl index 7bd3c61..374bc7e 100644 --- a/test/simple.tl +++ b/test/simple.tl @@ -197,112 +197,167 @@ \ \n \ \
") -(exit) - ;;; 15 -(string= (with-html-output-to-string (out) - (:table :border 0 :cellpadding 4 - (loop for i below 25 by 5 - do (htm - (:tr :align "right" - (loop for j from i below (+ i 5) - do (htm - (:td :bgcolor (if (oddp j) - "pink" - "green") - (fmt "~@R" (1+ j)))))))))) - "
IIIIIIIVV
VIVIIVIIIIXX
XIXIIXIIIXIVXV
XVIXVIIXVIIIXIXXX
XXIXXIIXXIIIXXIVXXV
") + +(test (with-html-output-to-string (out) + (:table :border 0 :cellpadding 4 + (for ((i 0)) ((< i 25)) ((inc i 5)) + (htm + (:tr :align "right" + (for ((j i)) ((< j (+ i 5))) ((inc j)) + (htm + (:td :bgcolor (if (oddp j) + "pink" + "green") + (fmt "~X" (succ j)))))))))) + " \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ + \ +
12345
6789A
BCDEF
1011121314
1516171819
") ;;; 16 -(string= (with-html-output-to-string (out) - (:h4 "Look at the character entities generated by this example") - (loop for i from 0 - for string in '("Fête" "Sørensen" "naïve" "Hühner" "Straße") - do (htm - (:p :style (conc "background-color:" (case (mod i 3) - ((0) "red") - ((1) "orange") - ((2) "blue"))) - (htm (esc string)))))) - "

Look at the character entities generated by this example

Fête

Sørensen

naïve

Hühner

Straße

") +;;; The non-ASCII characters here are ISO Latin, not UTF-8. +;;; That's how they are in the original CL-WHO file. +;;; The TXR Lisp html-esc function doesn't do anything with those characters. +;;; They are non-UTF8 bytes that get mapped to \xDCxx characters, which +;;; reproduce those bytes on output. +(test (with-html-output-to-string (out) + (:h4 "Look at the character entities generated by this example") + (each ((i 0) + (string '("Fête" "Sørensen" "naïve" "Hühner" "Straße"))) + (htm + (:p :style (join "background-color:" (caseql (mod i 3) + ((0) "red") + ((1) "orange") + ((2) "blue"))) + (htm (esc string)))))) + "

Look at the character entities generated by this example

\ +

Fête

\ +

Sørensen

\ +

naïve

\ +

Hühner

\ +

Straße

") + ;;; 17 -(flet ((checkbox (stream name checked &optional value) +(flet ((checkbox (stream name checked : value) (with-html-output (stream) (:input :type "checkbox" :name name :checked checked :value value)))) - (and (string= (with-output-to-string (s) (checkbox s "foo" t)) - "") - (string= (with-output-to-string (s) (checkbox s "foo" nil)) - "") - (string= (with-output-to-string (s) (checkbox s "foo" nil "bar")) - "") - (string= (with-output-to-string (s) (checkbox s "foo" t "bar")) - ""))) + (test (with-out-string-stream (s) (checkbox s "foo" t)) + "") + (test (with-out-string-stream (s) (checkbox s "foo" nil)) + "") + (test (with-out-string-stream (s) (checkbox s "foo" nil "bar")) + "") + (test (with-out-string-stream (s) (checkbox s "foo" t "bar")) + "")) ;;; 18 -(string= (with-html-output-to-string (out) - (:p)) - "

") +(test (with-html-output-to-string (out) + (:p)) + "

") ;;; 19 -(string= (let ((cl-who:*html-empty-tag-aware-p* nil)) - (eval `(with-html-output-to-string (out) - (:p)))) - "

") +(test (let ((tl-who:*html-empty-tag-aware-p* nil)) + (eval ^(with-html-output-to-string (out) + (:p)))) + "

") ;;; 20 -(string= (let ((*html-empty-tag-aware-p* t) - (*html-empty-tags* '(:p))) - (eval `(with-html-output-to-string (out) - (:p)))) - "

") +(test (let ((*html-empty-tag-aware-p* t) + (*html-empty-tags* '(:p))) + (eval '(with-html-output-to-string (out) + (:p)))) + "

") ;;; 21 -(string= (with-html-output-to-string (out) - (:|Foo| :bar 42)) - "") +;;; Adjusted from CL-WHO test 21. +;;; TXR Lisp doesn't have || escapes in symbol names, and is case-sensitive. +(test (with-html-output-to-string (out) + (:Foo :bar 42)) + "") ;;; 22 -(string= (let ((*downcase-tokens-p* nil)) - (eval `(with-html-output-to-string (out) - (:|Foo| :bar 42)))) - "") +;;; Adjusted from CL-WHO test 22 +;;; TL-WHO has *upcase-tokens-p* +(test (let ((*upcase-tokens-p* t)) + (eval '(with-html-output-to-string (out) + (:Foo :bar 42)))) + "") + ;;; 23 -(string= (let* ((list (list (make-string-output-stream) (make-string-output-stream))) - (stream (first list))) - (with-html-output (var (pop list)) - (progn (htm (:br)))) - (get-output-stream-string stream)) - "
") +(test (let* ((list (list (make-string-output-stream) + (make-string-output-stream))) + (stream (first list))) + (with-html-output (var (pop list)) + (progn (htm (:br)))) + (get-string-from-stream stream)) + "
") ;;; 24 -(string= (with-html-output-to-string (out) - (:div (:pre "Foo"))) - "

Foo
") +(test (with-html-output-to-string (out) + (:div (:pre "Foo"))) + "
Foo
") + ;;; 25 -(string= (with-html-output-to-string (out nil :indent t) - (:div (:pre "Foo"))) - " -
- 
Foo
-
") +(test (with-html-output-to-string (out nil :indent t) + (:div (:pre "Foo"))) + "\n \ +
\n \ + \ 
Foo
\n \ +
") ;;; 26 -(string= (with-html-output-to-string (out nil :indent t) - (:div (:p "Bar"))) - " -
-

Bar -

-
") +(test (with-html-output-to-string (out nil :indent t) + (:div (:p "Bar"))) + "\n \ +
\n \ + \

Bar\n \ + \

\n \ +
") + ;;; 27 -(string= (let ((*html-no-indent-tags* (cons :p *html-no-indent-tags*))) - (eval `(with-html-output-to-string (out nil :indent t) - (:div (:p "Bar"))))) - " -
-

Bar

-
") +;;; CL-WHO test 27 uses let and eval; we eliminate that with expander-let. +(test (expander-let ((*html-no-indent-tags* (cons :p *html-no-indent-tags*))) + (with-html-output-to-string (out nil :indent t) + (:div (:p "Bar")))) + "\n \ +
\n \ + \

Bar

\n \ +
") diff --git a/who.tl b/who.tl index 79b8e25..2683450 100644 --- a/who.tl +++ b/who.tl @@ -73,8 +73,7 @@ ((keywordp (first rest)) (push (cons (first rest) (second rest)) attr)) (t - (set attr-list (nreverse attr) - body rest + (set body rest rest nil)))) (set attr-list (nreverse attr)))) ((listp head) -- cgit v1.2.3