# -*- tcl -*-
# Code common to the various control files.
#
# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# All rights reserved.
#
# RCS: @(#) $Id: common,v 1.3 2009/04/29 02:09:46 andreas_kupries Exp $

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

# Similar to TestFiles in devtools/testutilities.tcl, but not
# identical.  Here we do not expect source'able test suites, but data
# files, organized in sections under a main directory.

proc TestFilesProcess {maindir section inset outset -> nv lv iv dv ev script} {
    upvar 1 $nv n $lv label $dv data $ev expected $iv inputfile

    set pattern $maindir/$section/$inset/*

    set files [TestFilesGlob $pattern]
    if {![llength $files]} {
	return -code error "No files matching \"$pattern\""
    }
    foreach src $files {
	if {[string match *README* $src]} continue
	if {[file isdirectory      $src]} continue

	set srcname  [file tail $src]
	set exp      [localPath $maindir]/$section/$outset/$srcname
	set data     [fileutil::cat $src]
	set expected [string trim [fileutil::cat $exp]]
	set expected [string map [list @ $::tcltest::testsDirectory] $expected]

	regexp -- {^([0-9]+)}    $srcname -> n
	regsub -all -- {^[0-9]+} $srcname {} label

	scan $n %d n
	set label [string trim [string map {_ { }} $label]]
	set inputfile $src

	uplevel 1 $script
    }
    return
}

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

proc setup_plugins {} {
    global env

    array_unset env LANG*
    array_unset env LC_*
    set env(LANG) C ; # Usually default if nothing is set, OS X requires this.

    set paths [join [list \
			 [tcllibPath doctools2] \
			 [tcllibPath struct] \
			 [tcllibPath textutil]] \
		   [expr {$::tcl_platform(platform) eq "windows" ? ";" : ":"}]]

    # Initialize the paths an import plugin manager should use when
    # searching for an import plugin used by the code under test, and
    # also provide the paths enabling the import plugins to find their
    # supporting packages as well.

    set env(DOCTOOLS_IDX_IMPORT_PLUGINS) $paths

    # Initialize the paths an export plugin manager should use when
    # searching for an export plugin used by the code under test, and
    # also provide the paths enabling the export plugins to find their
    # supporting packages as well.

    set env(DOCTOOLS_IDX_EXPORT_PLUGINS) $paths

    return
}

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

proc stripcomments {text} {
    set pattern {[[:space:]]*\[comment[[:space:]][[:space:]]*\{[^\}]*\}[[:space:]]*\][[:space:]]*}
    regsub -all -- $pattern $text {} text
    return $text
}

proc striphtmlcomments {text {n {}}} {
    set pattern {<!--.*?-->}
    if {$n eq {}} {
	regsub -all -- $pattern $text {} text
    } else {
	while {$n} {
	    regsub -- $pattern $text {} text
	    incr n -1
	}
    }
    return $text
}

proc stripmanmacros {text} {
    return [string map [list \n[doctools::nroff::man_macros::contents] {}] $text]
}

proc stripnroffcomments {text {n {}}} {
#    return $text
    set pattern "'\\\\\"\[^\n\]*\n"
    if {$n eq {}} {
	regsub -all -- $pattern $text {} text
    } else {
	while {$n} {
	    regsub -- $pattern $text {} text
	    incr n -1
	}
    }
    return $text
}

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

# 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 {}
    $t 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
}

# Callbacks for tree walking.
# Remember the node in a global variable.

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

proc match_tree {ta tb} {
    match_node $ta [$ta rootname] $tb [$tb rootname]
    return
}

proc match_node {ta a tb b} {
    if {[dictsort [$ta getall $a]] ne [dictsort [$tb getall $b]]} {
	return -code error "$ta/$a at $tb/$b, attribute mismatch (([dictsort [$ta getall $a]]) ne ([dictsort [$tb getall $b]]))"
    }
    if {[llength [$ta children $a]] != [llength [$tb children $b]]} {
	return -code error "$ta/$a at $tb/$b, children mismatch"
    }
    foreach ca [$ta children $a] cb [$tb children $b] {
	match_node $ta $ca $tb $cb
    }
    return
}

# -------------------------------------------------------------------------
return