head	1.1;
access;
symbols
	tcllib-1-13:1.1
	tcllib-1-12:1.1
	tklib-0-5:1.1
	tcllib-1-11-1:1.1
	tcllib-1-11:1.1
	tcllib-1-10:1.1;
locks; strict;
comment	@# @;


1.1
date	2007.04.12.03.01.56;	author andreas_kupries;	state Exp;
branches;
next	;


desc
@@


1.1
log
@
	* sets.tcl: Renamed various commands handling accelerators. This
	  brought their names into compliance with the requirements of the
	  'TestAccel*' commands in devtools.

	* sets.test: Rewritten to use the 'TestAccel*' convenience
	  commands.

	* tree.test: Rewritten to use the 'TestAccel*' convenience
	  commands. Additionally moved the helper commands into a new,
	  separate file

	* tree/tests/Xsupport: New file now containing the helper commands
	  for testing struct::tree.

	* graph.test: Rewritten to make use of 'useAccel'.

	* graph.test:               The testsuite already switches various
	* graph/tests/arcs.test:    implementations of struct::graph. Added
	* graph/tests/assign.test:  the switching of struct::set
	* graph/tests/command.test: implementations.
	* graph/tests/deserialize.test:
	* graph/tests/nodes.test:
	* graph/tests/rassign.test:
	* graph/tests/serialize.test:
	* graph/tests/swap.test:
	* graph/tests/walk.test:
	* graph/tests/arc/attr.test:
	* graph/tests/arc/delete.test:
	* graph/tests/arc/exists.test:
	* graph/tests/arc/flip.test:
	* graph/tests/arc/insert.test:
	* graph/tests/arc/move-source.test:
	* graph/tests/arc/move-target.test:
	* graph/tests/arc/move.test:
	* graph/tests/arc/rename.test:
	* graph/tests/arc/source.test:
	* graph/tests/arc/target.test:
	* graph/tests/attr/append.test:
	* graph/tests/attr/get.test:
	* graph/tests/attr/getall.test:
	* graph/tests/attr/keyexists.test:
	* graph/tests/attr/keys.test:
	* graph/tests/attr/lappend.test:
	* graph/tests/attr/set.test:
	* graph/tests/attr/unset.test:
	* graph/tests/node/attr.test:
	* graph/tests/node/degree.test:
	* graph/tests/node/delete.test:
	* graph/tests/node/exists.test:
	* graph/tests/node/insert.test:
	* graph/tests/node/opposite.test:
	* graph/tests/node/rename.test:
@
text
@# -*- tcl -*-
# tree.testsupport:  Helper commands for the testsuite.
#
# Copyright (c) 2007 Andreas Kupries <andreas_kupries@@users.sourceforge.net>
#
# All rights reserved.
#
# RCS: @@(#) $Id: Xsupport,v 1.1 2006/11/16 06:33:13 andreas_kupries Exp $

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

# Callbacks for tree walking.
# Remember 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
}

#----------------------------------------------------------------------
@
