# Tests for the tie module.                              -*- tcl -*- 
#
# Copyright (c) 2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>
# All rights reserved.
#
# This is a tie for remote array ties, actually using separate
# processes. This is based on the package "comm", also in Tcllib.
#
# RCS: @(#) $Id: tie_rarray_comm.test,v 1.5 2005/09/28 04:51:24 andreas_kupries Exp $

if {![package vsatisfies [package provide Tcl] 8.4]} {
    puts "Aborting tests for snit."
    puts "Requiring Tcl 8.4, have [package present Tcl]"
    return
}

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

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and not one installed somewhere else.
# We also ensure to use local copies of the prerequisite packages.

package forget tie::std::rarray
package forget tie
package forget comm
package forget snit
package forget cmdline

catch {namespace delete tie::std::rarray}
catch {namespace delete tie}
catch {namespace delete comm}
catch {namespace delete snit}
catch {namespace delete cmdline}

set tie_ra_code  [file join [file dirname [info script]] tie_rarray.tcl]
set tie_code     [file join [file dirname [info script]] tie.tcl]
set comm_code    [file join [file dirname [info script]] .. comm comm.tcl]
set snit_code    [file join [file dirname [info script]] .. snit snit.tcl]
set cmdline_code [file join [file dirname [info script]] .. cmdline cmdline.tcl]

if {[catch {source $cmdline_code} msg]} {
    puts "skipped [file tail [info script]] (cmdline.tcl): $msg"
    return
}
if {[catch {source $snit_code} msg]} {
    puts "skipped [file tail [info script]] (snit.tcl): $msg"
    return
}
if {[catch {source $tie_ra_code} msg]} {
    puts "skipped [file tail [info script]] (tie_rarray.tcl): $msg"
    return
}
if {[catch {source $tie_code} msg]} {
    puts "skipped [file tail [info script]] (tie.tcl): $msg"
    return
}
if {[catch {source $comm_code} msg]} {
    puts "skipped [file tail [info script]] (comm.tcl): $msg"
    return
}

puts "tie::std::rarray [package present tie::std::rarray]"
puts "- tie            [package present tie]"
puts "- snit           [package present snit]"
puts "- comm           [package present comm]"
puts "- cmdline        [package present cmdline]"

# -------------------------------------------------------------------------
# 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
}

proc mysend {args} {
    # A fake send command, also local receiver, in a way.
    # args = options?... id cmd arg...
    # Options used is -async. Id is irrelevant here.

    set async [expr {[lindex $args 0] eq "-async"}]
    if {$async} {set args [lrange $args 1 end]}
    set args [lrange $args 1 end]
    set code [catch {uplevel 1 $args} msg]
    if {$async} return
    return -code $code $msg
}

# ------------------------------------------------------------------------
#
# First order of things is to spawn a separate tclsh into the background
# and have it execute comm too, with some general code to respond to our
# requests

set path(spawn) [makeFile {
    ##puts [set fh [open ~/foo w]] $argv ; close $fh

    set master [lindex $argv 1]
    source     [lindex $argv 0] ; # load 'comm'
    # and wait for commands. But first send our
    # own server socket to the initiator
    ::comm::comm send $master [list slaveat [::comm::comm self]]
    #comm::comm debug 1
    vwait forever
} spawn]

proc slaveat {id} {
    puts "Slave @ $id"
    proc slave {} [list return $id]
    set ::go .
}

puts "self @ [::comm::comm self]"

exec [info nameofexecutable] $path(spawn) $comm_code [::comm::comm self] &

puts "Waiting for spawned comm system to boot"
# Wait for the slave to initialize itself.
vwait ::go

interp alias {} csend  {} comm::comm send [slave]
interp alias {} csenda {} comm::comm send -async [slave]

puts "Running tests"
#::comm::comm debug 1
# ------------------------------------------------------------------------

# -------------------------------------------------------------------------
# We wish to test the regular rmeote communication, and circular
# communication, i.e. (1) a tie from A to remote B, and (2) ties from
# A to B and back.

# We assume that the regular tests for 'rarray' were successful.

test tie-rarray-comm-1.0 {init from remote} {
    unset -nocomplain av ; array set av {}

    csend {
	unset -nocomplain av
	array set av {a 3 ab 4 fox snarf foo bar}
    }

    tie::tie av remotearray av {comm::comm send} [slave]
    tie::untie av

    set res [dictsort [array get av]]
    unset av
    set res
} {a 3 ab 4 foo bar fox snarf}

test tie-rarray-comm-1.1 {persistence to remote} {
    unset -nocomplain av ; array set av {}

    csend {
	unset -nocomplain av
	array set av {a 1 b 2 c 3}
    }

    tie::tie av remotearray av {comm::comm send} [slave]

    proc peek {} {
	global r
	lappend r [dictsort [csend {array get av}]]
	return
    }

    set r {}               ; peek
    set av(a) 4            ; peek
    set av(ax) foo         ; peek
    array unset av a*      ; peek
    array set av {b 5 d 6} ; peek

    tie::untie av
    rename peek {}
    unset av
    join $r \n
} {a 1 b 2 c 3
a 4 b 2 c 3
a 4 ax foo b 2 c 3
b 2 c 3
b 5 c 3 d 6}



# -------------------------------------------------------------------------
# Circular ties between local and remote array

test tie-rarray-comm-2.0 {circular init to remote} {
    unset -nocomplain av ; array set av {}

    csend {
	unset -nocomplain av
	array set av {a 3 ab 4 fox snarf foo bar}
    }

    tie::tie av remotearray av {comm::comm send} [slave]

    csend [list source $cmdline_code]
    csend [list source $snit_code]
    csend [list source $tie_code]
    csend [list source $tie_ra_code]
    set msg [csend {
	tie::tie av remotearray av {comm::comm send} $master
    }] ; # {}
    tie::untie av
    csend {tie::untie av}

    set res [dictsort [array get av]]
    unset av
    list $msg $res
} {tie1 {a 3 ab 4 foo bar fox snarf}}

test tie-rarray-comm-2.1 {circular persistence to remote} {
    unset -nocomplain av ; array set av {}

    csend {
	unset -nocomplain av
	array set av {a 1 b 2 c 3}
    }

    tie::tie av remotearray av {comm::comm send} [slave]
    csend [list source $cmdline_code]
    csend [list source $snit_code]
    csend [list source $tie_code]
    csend [list source $tie_ra_code]
    set msg [csend {
	tie::tie av remotearray av {comm::comm send} $master
    }] ; # {}

    proc peek {} {
	global r
	lappend r [dictsort [csend {array get av}]]
	return
    }

    set r {}               ; peek
    set av(a) 4            ; peek
    set av(ax) foo         ; peek
    array unset av a*      ; peek
    array set av {b 5 d 6} ; peek

    tie::untie av
    rename peek {}
    unset av
    join $r \n
} {a 1 b 2 c 3
a 4 b 2 c 3
a 4 ax foo b 2 c 3
b 2 c 3
b 5 c 3 d 6}

# -------------------------------------------------------------------------
# As part of the cleanup ensure that the slave we used here is killed.

csenda {{exit}}
::comm::comm abort

interp alias {} csend
::tcltest::cleanupTests
return