Commits

Taylor Venable committed e3d856b

Make XML tests work again

Comments (0)

Files changed (3)

-package ifneeded tcv::flexwriter 1.0 [list source [file join $dir "flexwriter.tcl"]]
-package ifneeded tcv::multilog 1.0 [list source [file join $dir "multilog.tcl"]]
-package ifneeded tcv::eproc 1.0 [list source [file join $dir "eproc.tcl"]]
-package ifneeded tcv::colorpick 1.0 [list source [file join $dir "colorpick.tcl"]]
+namespace eval __tcv_pkg_tmp [list variable dir $dir]
+namespace eval __tcv_pkg_tmp {
+    set pkgs {
+        colorpick
+        eproc
+        flexwriter
+        multilog
+        sexp
+        xml
+    }
+
+    foreach pkg $pkgs {
+        package ifneeded tcv::$pkg 1.0 \
+            [list source [file join $dir "$pkg.tcl"]]
+    }
+}
+namespace delete __tcv_pkg_tmp
 
 package ifneeded tcv::erlang 1.0 "
     source [file join $dir erlang src term.tcl]
-#!/usr/bin/env tclsh
+### Copyright (c) 2013, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
 
-######################################################################
-###                                                                ###
-###  Copyright (c) 2010, Taylor Venable.                           ###
-###  All rights reserved.                                          ###
-###                                                                ###
-######################################################################
+package provide tcv::xml 1.0
 
-namespace eval ::tcvXML {
+namespace eval tcv::xml {
     variable option
-    
+
     set option(ignore-whitespace-only-text-nodes) true
     set option(debugging-output) off
+
     proc maybe_puts {msg} {
-        if {$::tcvXML::option(debugging-output)} {
+        variable option
+
+        if {$option(debugging-output)} {
             puts stderr $msg
         }
     }
-        proc read_from_string {name regexp} {
+
+    proc read_from_string {name regexp} {
         upvar $name s
         if {[regexp "^.*?$regexp" $s match]} {
             set s [string range $s [string length $match] end]
         }
         return ""
     }
+
     proc read_one_char {name} {
         upvar $name s
         set result [string index $s 0]
         set s [string range $s 1 end]
         return $result
     }
+
     proc push_back {name prefix} {
         upvar $name s
         set s "${prefix}${s}"
     }
+
     proc consume_space {name} {
         upvar $name s
         set s [string trimleft $s]
     }
+
     proc parse {xml} {
         return [do_parse TOP]
     }
-    
+
     proc do_parse {state} {
+        variable option
+
         upvar xml xml
-    
+
         switch -- $state {
             {TOP} {
                 set pre [string trim [read_from_string xml {<}]]
                     {>} { error "No tag name" }
                     {default} {     set current {NODE}
                                 set self_closed false
-                                
+
                                 consume_space xml
-                                
+
                                 set tag [read_from_string xml {[\s/>]}]
                                 push_back xml [string index $tag end]
                                 set tag "$next[string range $tag 0 end-1]"
                                 set attribs [string trim [string range [read_from_string xml {>}] 0 end-1]]
-                                
+
                                 if {[string index $attribs end] eq "/"} {
                                     set self_closed true
                                     set attribs [string range $attribs 0 end-1]
                                 }
-                                
+
                                 set attr_list {}
                                 while {$attribs ne ""} {
                                     set attr_name [read_from_string attribs {=}]
                                     if {$attr_name eq ""} { error "No attribute value" }
                                     if {$attr_name eq "="} { error "No attribute name" }
                                     set attr_name [string range $attr_name 0 end-1]
-                                
+
                                     read_from_string attribs {\"}
                                     if {[string index $attribs 0] eq {\"}} {
                                         set attr_value {}
                                     lappend attr_list $attr_name
                                     lappend attr_list $attr_value
                                 }
-                                
+
                                 maybe_puts "Start=$tag"
                                 maybe_puts "Attrib=$attr_list"
-                                
+
                                 lappend current $tag
                                 lappend current $attr_list
-                                
+
                                 if {$self_closed} {
                                     return $current
                                 } else {
                                     set child [do_parse CHILD]
-                                
+
                                     while {$child ne {} && [lindex $child 0] ne "CLOSE_NODE"} {
                                         lappend current $child
                                         set child [do_parse CHILD]
                                     }
-                                
+
                                     if {$child eq {}} {
                                         error "Unexpected EOF while looking for end of $tag"
                                     } elseif {[lindex $child 1] ne $tag} {
                             {>} { error "No tag name" }
                             {default} {     set current {NODE}
                                         set self_closed false
-                                        
+
                                         consume_space xml
-                                        
+
                                         set tag [read_from_string xml {[\s/>]}]
                                         push_back xml [string index $tag end]
                                         set tag "$next[string range $tag 0 end-1]"
                                         set attribs [string trim [string range [read_from_string xml {>}] 0 end-1]]
-                                        
+
                                         if {[string index $attribs end] eq "/"} {
                                             set self_closed true
                                             set attribs [string range $attribs 0 end-1]
                                         }
-                                        
+
                                         set attr_list {}
                                         while {$attribs ne ""} {
                                             set attr_name [read_from_string attribs {=}]
                                             if {$attr_name eq ""} { error "No attribute value" }
                                             if {$attr_name eq "="} { error "No attribute name" }
                                             set attr_name [string range $attr_name 0 end-1]
-                                        
+
                                             read_from_string attribs {\"}
                                             if {[string index $attribs 0] eq {\"}} {
                                                 set attr_value {}
                                             lappend attr_list $attr_name
                                             lappend attr_list $attr_value
                                         }
-                                        
+
                                         maybe_puts "Start=$tag"
                                         maybe_puts "Attrib=$attr_list"
-                                        
+
                                         lappend current $tag
                                         lappend current $attr_list
-                                        
+
                                         if {$self_closed} {
                                             return $current
                                         } else {
                                             set child [do_parse CHILD]
-                                        
+
                                             while {$child ne {} && [lindex $child 0] ne "CLOSE_NODE"} {
                                                 lappend current $child
                                                 set child [do_parse CHILD]
                                             }
-                                        
+
                                             if {$child eq {}} {
                                                 error "Unexpected EOF while looking for end of $tag"
                                             } elseif {[lindex $child 1] ne $tag} {
                     {default} {
                         set text "$first[string range [read_from_string xml {<}] 0 end-1]"
                         push_back xml <
-                        if {$::tcvXML::option(ignore-whitespace-only-text-nodes) && [regexp {^\s*$} $text]} {
+                        if {$option(ignore-whitespace-only-text-nodes) && [regexp {^\s*$} $text]} {
                             return [do_parse CHILD]
                         } else {
                             return [list TEXT $text]
 #!/usr/bin/env tclsh
 
-######################################################################
-###                                                                ###
-###  Copyright (c) 2010, Taylor Venable.                           ###
-###  All rights reserved.                                          ###
-###                                                                ###
-######################################################################
+### Copyright (c) 2013, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
 
-source tcvXML.tcl
+lappend auto_path [file normalize [file join [pwd] .. src]]
+package require tcv::xml
 
 set test_counter 0
 
 proc test_equal {name lst} {
     test_header
     upvar $name xml
-    set xml [::tcvXML::parse $xml]
+    set xml [tcv::xml::parse $xml]
     if {"{$xml}" eq "{$lst}"} {
         puts "PASS"
     } else {
 }
 
 proc test_error {name xml expected} {
-    if {!$::tcvXML::option(debugging-output)} { test_header }
-    if {[catch {::tcvXML::parse $xml} error]} {
+    if {!$tcv::xml::option(debugging-output)} { test_header }
+    if {[catch {tcv::xml::parse $xml} error]} {
         if {[string first $expected $error] == 0} {
             puts "PASS"
         } else {
-            if {!$::tcvXML::option(debugging-output)} {
+            if {!$tcv::xml::option(debugging-output)} {
                 puts "FAIL"
                 puts [string repeat = 80]
                 puts "XML: $xml\nExpected: $expected\nFound: $error"
                 puts [string repeat - 80]
-                set ::tcvXML::option(debugging-output) on
+                set tcv::xml::option(debugging-output) on
                 test_error $name $xml $expected
-                set ::tcvXML::option(debugging-output) off
+                set tcv::xml::option(debugging-output) off
                 puts [string repeat = 80]
             }
         }
 }
 
 puts stderr [string repeat * 80]
-puts stderr [::tcvXML::parse {<foo>
+puts stderr [tcv::xml::parse {<foo>
   <bar yes="no">42</bar>
   <spam>alpha</spam>
 </foo>}]