html.templates.chloe: add notion of "string context" where tags are not allowed and <>& are not escaped; fixes <t:title> double escaping bug reported by John Benediktsson

basis/html/components/components.factor

@@ -25,6 +25,19 @@ GENERIC: render* ( value name renderer -- xml )
 : render ( name renderer -- )
     render>xml write-xml ;
 
+<PRIVATE
+
+GENERIC: write-nested ( obj -- )
+
+M: string write-nested write ;
+
+M: sequence write-nested [ write-nested ] each ;
+
+PRIVATE>
+
+: render-string ( name renderer -- )
+    render>xml write-nested ;
+
 SINGLETON: label
 
 M: label render*

basis/html/templates/chloe/chloe-tests.factor

@@ -5,6 +5,9 @@ splitting furnace accessors
 html.templates.chloe.compiler ;
 IN: html.templates.chloe.tests
 
+! So that changes to code are reflected
+[ ] [ reset-cache ] unit-test
+
 : run-template ( quot -- string )
     with-string-writer [ "\r\n\t" member? not ] filter
     "?>" split1 nip ; inline
@@ -170,3 +173,24 @@ TUPLE: person first-name last-name ;
         "test13" test-template call-template
     ] run-template
 ] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with
+
+[ "Hello &lt;world&gt; &amp;escaping test;" "Hello <world> &escaping test;" ] [
+    [
+        <box> title set
+        [
+            begin-form
+            "&escaping test;" "a-value" set-value
+            "test14" test-template call-template
+        ] run-template
+        title get box>
+    ] with-scope
+] unit-test
+
+[
+    [
+        <box> title set
+        [
+            "test15" test-template call-template
+        ] run-template
+    ] with-scope
+] [ error>> tag-not-allowed-here? ] must-fail-with

basis/html/templates/chloe/compiler/compiler.factor

@@ -70,7 +70,15 @@ DEFER: compile-element
     name>string [write]
     ">" [write] ;
 
+SYMBOL: string-context?
+
+ERROR: tag-not-allowed-here ;
+
+: check-tag ( -- )
+    string-context? get [ tag-not-allowed-here ] when ;
+
 : compile-tag ( tag -- )
+    check-tag
     {
         [ main>> tag-stack get push ]
         [ compile-start-tag ]
@@ -87,13 +95,20 @@ ERROR: unknown-chloe-tag tag ;
     [ unknown-chloe-tag ]
     ?if ;
 
+: compile-string ( string -- )
+    string-context? get [ escape-string ] unless [write] ;
+
+: compile-misc ( object -- )
+    check-tag
+    [ write-xml ] [code-with] ;
+
 : compile-element ( element -- )
     {
         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
-        { [ dup string? ] [ escape-string [write] ] }
+        { [ dup string? ] [ compile-string ] }
         { [ dup comment? ] [ drop ] }
-        [ [ write-xml ] [code-with] ]
+        [ compile-misc ]
     } cond ;
 
 : with-compiler ( quot -- quot' )
@@ -119,7 +134,9 @@ ERROR: unknown-chloe-tag tag ;
     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 
 : compile-children>string ( tag -- )
-    [ with-string-writer ] process-children ;
+    t string-context? [
+        [ with-string-writer ] process-children
+    ] with-variable ;
 
 : compile-with-scope ( quot -- )
     compile-quot [ with-scope ] [code] ; inline

basis/html/templates/chloe/components/components.factor

@@ -1,17 +1,23 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel parser fry quotations
-classes.tuple classes.singleton
+classes.tuple classes.singleton namespaces
 html.components
 html.templates.chloe.compiler
 html.templates.chloe.syntax ;
 IN: html.templates.chloe.components
-  
+
+: render-quot ( -- quot )
+    string-context? get
+    [ render-string ]
+    [ render ]
+    ? ;
+
 GENERIC: component-tag ( tag class -- )
 
 M: singleton-class component-tag ( tag class -- )
     [ "name" required-attr compile-attr ]
-    [ literalize [ render ] [code-with] ]
+    [ literalize render-quot [code-with] ]
     bi* ;
 
 : compile-component-attrs ( tag class -- )
@@ -23,7 +29,7 @@ M: singleton-class component-tag ( tag class -- )
 M: tuple-class component-tag ( tag class -- )
     [ drop "name" required-attr compile-attr ]
     [ compile-component-attrs ] 2bi
-    [ render ] [code] ;
+    render-quot [code] ;
 
 SYNTAX: COMPONENT:
     scan-word

basis/html/templates/templates.factor

@@ -29,13 +29,20 @@ M: template-error error.
 : call-template ( template -- )
     [ call-template* ] [ \ template-error boa rethrow ] recover ;
 
+ERROR: no-boilerplate ;
+
+M: no-boilerplate error.
+    drop
+    "get-title and set-title can only be used from within" print
+    "a with-boilerplate form" print ;
+
 SYMBOL: title
 
 : set-title ( string -- )
-    title get >box ;
+    title get [ >box ] [ no-boilerplate ] if* ;
 
 : get-title ( -- string )
-    title get value>> ;
+    title get [ value>> ] [ no-boilerplate ] if* ;
 
 : write-title ( -- )
     get-title write ;