From 1194ce38aa979e60d694f953b41c89fe2fad014c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 31 Jan 2009 21:01:55 -0600
Subject: [PATCH] Fix some bugs in xml.utilities and add new unit tests

---
 basis/xml/utilities/utilities-tests.factor | 10 +++++-
 basis/xml/utilities/utilities.factor       | 36 +++++++++++++---------
 2 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/utilities/utilities-tests.factor
index 7b0989611c..673bf47f6e 100644
--- a/basis/xml/utilities/utilities-tests.factor
+++ b/basis/xml/utilities/utilities-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: xml xml.utilities tools.test xml.data ;
+USING: xml xml.utilities tools.test xml.data sequences ;
 IN: xml.utilities.tests
 
 [ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@@ -12,3 +12,11 @@ IN: xml.utilities.tests
 XML-NS: foo http://blah.com
 
 [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
+
+[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
+
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
+
+[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
+
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test
\ No newline at end of file
diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor
index d286072be6..1249da8c36 100755
--- a/basis/xml/utilities/utilities.factor
+++ b/basis/xml/utilities/utilities.factor
@@ -8,8 +8,10 @@ IN: xml.utilities
 : children>string ( tag -- string )
     children>> {
         { [ dup empty? ] [ drop "" ] }
-        { [ dup [ string? not ] any? ]
-          [ "XML tag unexpectedly contains non-text children" throw ] }
+        {
+            [ dup [ string? not ] any? ]
+            [ "XML tag unexpectedly contains non-text children" throw ]
+        }
         [ concat ]
     } cond ;
 
@@ -22,20 +24,24 @@ IN: xml.utilities
 : tag-named? ( name elem -- ? )
     dup tag? [ names-match? ] [ 2drop f ] if ;
 
-: tags@ ( tag name -- children name )
-    [ { } like ] dip assure-name ;
-
-: deep-tag-named ( tag name/string -- matching-tag )
-    assure-name '[ _ swap tag-named? ] deep-find ;
-
-: deep-tags-named ( tag name/string -- tags-seq )
-    tags@ '[ _ swap tag-named? ] deep-filter ;
-
 : tag-named ( tag name/string -- matching-tag )
-    assure-name swap [ tag-named? ] with find nip ;
+    assure-name '[ _ swap tag-named? ] find nip ;
 
 : tags-named ( tag name/string -- tags-seq )
-    tags@ swap [ tag-named? ] with filter ;
+    assure-name '[ _ swap tag-named? ] filter { } like ;
+
+<PRIVATE
+
+: prepare-deep ( xml name/string -- tag name/string )
+    [ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
+
+PRIVATE>
+
+: deep-tag-named ( tag name/string -- matching-tag )
+    prepare-deep '[ _ swap tag-named? ] deep-find ;
+
+: deep-tags-named ( tag name/string -- tags-seq )
+    prepare-deep '[ _ swap tag-named? ] deep-filter { } like ;
 
 : tag-with-attr? ( elem attr-value attr-name -- ? )
     rot dup tag? [ swap attr = ] [ 3drop f ] if ;
@@ -44,13 +50,13 @@ IN: xml.utilities
     assure-name '[ _ _ tag-with-attr? ] find nip ;
 
 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ '[ _ _ tag-with-attr? ] filter children>> ;
+    assure-name '[ _ _ tag-with-attr? ] filter children>> ;
 
 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
     assure-name '[ _ _ tag-with-attr? ] deep-find ;
 
 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ '[ _ _ tag-with-attr? ] deep-filter ;
+    assure-name '[ _ _ tag-with-attr? ] deep-filter ;
 
 : get-id ( tag id -- elem )
     "id" deep-tag-with-attr ;