# tree.test:  tests for the tree structure. -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: tree.test,v 1.41 2005/09/28 04:51:24 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget struct::tree
package forget struct::list
package forget tcllibc

catch {namespace delete ::struct::tree}
catch {namespace delete ::struct::list}
catch {rename ::struct::tree {}}

set moddir  [file dirname [file dirname [file join [pwd] [info script]]]]
set tcllibc [file join $moddir tcllibc pkgIndex.tcl]

if {[file exists $tcllibc]} {
    # Fake load of specific package index, so that the following
    # require will not search through the package paths.
    set dir [file dirname $tcllibc]
    source $tcllibc
    unset dir
    package require tcllibc
}
if {[catch {source [file join $moddir struct list.tcl]} msg]} {
    puts "skipped [file tail [info script]] (list.tcl): $msg"
    return
}
if {[catch {source [file join $moddir struct tree.tcl]} msg]} {
    puts "skipped [file tail [info script]] (tree.tcl): $msg"
    return
}

struct::tree::SwitchTo {}

foreach e [struct::tree::KnownImpl] {
    if {[::struct::tree::LoadAccel $e]} {
	puts "- struct::tree [package provide struct::tree] (using $e)"
	switch -exact -- $e {
	    critcl {
		puts "  - tcllibc      [package present tcllibc]"
	    }
	    tcl {
		puts "  - struct::list [package present struct::list]"
	    }
	}
    }
}

#----------------------------------------------------------------------

# Takes a dictionary, returns a list containing the same dictionary,
# however the keys are sorted alphabetically. This allows for a true
# comparison of dictionary results.

proc dictsort {dict} {
    array set a $dict
    set out [list]
    foreach key [lsort [array names a]] {
	lappend out $key $a($key)
    }
    return $out
}

# Callback for tree walking. Remembers the node
# in a global variable.

proc walker {node} {
    lappend ::FOO $node
}

proc pwalker {tree n a} {
    lappend ::t $a $n
}

proc pwalkern {tree n a} {
    lappend ::t $n
}

proc pwalkercont {tree n a} {
    if {[string equal $n "b"]} {lappend ::t . ; return -code continue}
    lappend ::t $a $n
}

proc pwalkerbreak {tree n a} {
    if {[string equal $n "b"]} {lappend ::t . ; return -code break}
    lappend ::t $a $n
}

proc pwalkerret {tree n a} {
    if {[string equal $n "b"]} {
	lappend ::t .
	return -code return good-return
    }
    lappend ::t $a $n
}

proc pwalkererr {tree n a} {
    if {[string equal $n "b"]} {
	lappend ::t .
	error fubar
    }
    lappend ::t $a $n
}

proc pwalkerprune {tree n a} {
    lappend ::t $a $n
    if {$::prune && ($n == 2)} {struct::tree::prune}
}

proc pwalkerpruneb {tree n a} {
    lappend ::t $a $n
    if {($n == 2)} {struct::tree::prune}
}

# Validate a serialization against the tree it
# was generated from.

proc validate_serial {t serial {rootname {}}} {
    if {$rootname == {}} {
	set rootname [$t rootname]
    }

    # List length is multiple of 3
    if {[llength $serial] % 3} {
	return serial/wrong#elements
    }

    # Scan through list and built a number helper
    # structures (arrays).

    array set a  {}
    array set p  {}
    array set ch {}
    foreach {node parent attr} $serial {
	# Node has to exist in tree
	if {![$t exists $node]} {
	    return node/$node/unknown
	}
	if {![info exists ch($node)]} {set ch($node) {}}
	# Parent reference has to be empty or
	# integer, == 0 %3, >=0, < length serial
	if {$parent != {}} {
	    if {![string is integer -strict $parent]} {
		return node/$node/parent/no-integer/$parent
	    }
	    if {$parent % 3} {
		return node/$node/parent/not-triple/$parent
	    }
	    if {$parent < 0} {
		return node/$node/parent/out-of-bounds/$parent
	    }
	    if {$parent >= [llength $serial]} {
		return node/$node/parent/out-of-bounds/$parent
	    }
	    # Resolve parent index into node name, has to match
	    set parentnode [lindex $serial $parent]
	    if {![$t exists $parentnode]} {
		return node/$node/parent/unknown/$parent/$parentnode
	    }
	    if {![string equal [$t parent $node] $parentnode]} {
		return node/$node/parent/mismatch/$parent/$parentnode/[$t parent $node]
	    }
	    lappend ch($parentnode) $node
	} else {
	    set p($node) {}
	}
	# Attr list has to be of even length.
	if {[llength $attr] % 2} {
	    return attr/$node/wrong#elements
	}
	# Attr have to exist and match in all respects
	if {![string equal \
		[dictsort $attr] \
		[dictsort [$t getall $node]]]} {
	    return attr/$node/mismatch
	}
    }
    # Second pass, check that the children information is encoded
    # correctly. Reconstructed data has to match originals.

    foreach {node parent attr} $serial {
	if {![string equal $ch($node) [$t children $node]]} {
	    return node/$node/children/mismatch
	}
    }

    # Reverse check
    # - List of nodes from the 'rootname' and check
    #   that it and all its children are present
    #   in the structure.

    set ::FOO {}
    mytree walk $rootname n {walker $n}

    foreach n $::FOO {
	if {![info exists ch($n)]} {
	    return node/$n/mismatch/reachable/missing
	}
    }
    if {[llength $::FOO] != [llength $serial]/3} {
	return structure/mismatch/#nodes/multiples
    }
    if {[llength $::FOO] != [array size ch]} {
	return structure/mismatch/#nodes/multiples/ii
    }
    return ok
}

############################################################
## Iterate over all loaded implementations, activate
## them in turn, and run the tests for the active
## implementation. As a mini-benchmark we time how
## long each run takes.

puts "\ntree impl. performance"

set usec  0
set tests [file join [file dirname [info script]] tree.testsuite]

catch {memory validate on}

foreach impl [struct::tree::Implementations] {
    struct::tree::SwitchTo $impl

    # The global variable  'impl' is part of the public
    # API the testsuit (in tree.testsuite) can expect
    # from the environment.

    namespace import -force struct::tree

    switch -exact -- $impl {
	critcl {
	    set MY mytree

	    proc tmWrong {m loarg n {xarg {}}} {
		return [tcltest::wrongNumArgs "mytree $m" $loarg $n]
	    }

	    proc tmTooMany {m loarg {xarg {}}} {
		return [tcltest::tooManyArgs "mytree $m" $loarg]
	    }
	}
	tcl {
	    set MY ::mytree

	    proc tmWrong {m loarg n {xarg {}}} {
		if {$xarg == {}} {set xarg $loarg}
		if {$xarg != {}} {set xarg " $xarg"}
		incr n
		return [tcltest::wrongNumArgs "::struct::tree::_$m" "name$xarg" $n]
	    }

	    proc tmTooMany {m loarg {xarg {}}} {
		if {$xarg == {}} {set xarg $loarg}
		if {$xarg != {}} {set xarg " $xarg"}
		return [tcltest::tooManyArgs "::struct::tree::_$m" "name$xarg"]
	    }
	}
    }

    set usec [time {source $tests} 1]

    puts "$impl:\t$usec"
}

catch {memory validate off}

unset usec
unset tests

puts ""

# Reset system to fully inactive state.

struct::tree::SwitchTo {}

############################################################
::tcltest::cleanupTests