#! /bin/sh
# the next line restarts using tclsh8.5 on unix \
if type tclsh8.5 > /dev/null 2>&1 ; then exec tclsh8.5 "$0" ${1+"$@"} ; fi
# the next line restarts using tclsh85 on Windows using Cygwin \
if type tclsh85 > /dev/null 2>&1 ; then exec tclsh85 "`cygpath --windows $0`" ${1+"$@"} ; fi
# the next line complains about a missing tclsh \
echo "This software requires Tcl 8.5 to run." ; \
echo "Make sure that \"tclsh8.5\" or \"tclsh85\" is in your \$PATH" ; \
exit 1

lappend auto_path ../../orb ../../tclkill
package require tcltest
package require combat
package require kill

namespace import tcltest::test
tcltest::configure -verbose {body error pass}

if {[string first noexec $argv] == -1} {
    catch {file delete server.ior}
    set server [eval exec [info nameofexecutable] ./server.tcl $argv &]
}

catch {
    set argv [eval corba::init $argv]
    eval tcltest::configure $argv
    source test.tcl

    #
    # might need to wait for the server to start up
    #

    for {set i 0} {$i < 10} {incr i} {
	if {[file exists server.ior]} {
	    after 500
	    break
	}
	after 500
    }

    if {![file exists server.ior]} {
	catch {kill $server}
	puts "oops, server did not start up"
	exit 1
    }

    set reffile [open server.ior]
    set ior [read -nonewline $reffile]
    set obj [corba::string_to_object $ior]
    close $reffile

    #
    # beginning of tests
    #

    test operations-1.1 {short attribute} {
	$obj s 42
	$obj s
    } {42}
    test operations-1.2 {readonly string attribute} {
	$obj ra
    } {Hello World}
    test operations-1.3 {simple square op} {
	$obj square 42
    } {1764}
    test operations-1.4 {repeated op} {
	set sum 0
	for {set i 0} {$i < 100} {incr i} {
	    set sum [expr $i*$i-[$obj square $i]]
	}
	set sum
    } {0}

    test operations-2.1 {in and out strings} {
	set out Blubber
	set res [$obj copy "Hello World" out]
	list $res $out
    } {11 {Hello World}}
    test operations-2.2 {passing very long strings} {
	set str ""
	unset out
	for {set i 0} {$i < 1024} {incr i} {
	    append str "Hello World"
	}
	$obj copy $str out
	string compare $str $out
    } {0}

    test operations-3.1 {sequence passing} {
	set res [$obj length {{member 1} {member 2} {member 3} {member 4} {member 5} {member 6} {member 7} {member 8} {member 9}} e]
	list $res $e
    } {9 ODD}
    test operations-3.2 {empty sequence passing} {
	set res [$obj length {} e]
	list $res $e
    } {0 EVEN}

    test operations-4.1 {complex return value} {
	$obj squares 5
    } {{member 0} {member 1} {member 4} {member 9} {member 16}}

    test operations-5.1 {inout string, void return} {
	set str "Hello World"
	set res [$obj reverse str]
	list $res $str
    } {{} {dlroW olleH}}

    test operations-6.1 {oneway op} {
	$obj nop
    } {}

    test operations-7.1 {object reference return value} {
	set newobj [$obj dup]
	$newobj square 42
    } {1764}
    test operations-7.2 {object reference parameter} {
	$obj isme $obj
    } {1}
    test operations-7.3 {nil object reference parameter} {
	$obj isme 0
    } {0}
    test operations-7.4 {object reference out parameter} {
	unset newobj
	$obj dup2 $obj newobj
	$newobj isme $obj
    } {1}

    test operations-8.1 {_is_a builtin} {
	unset res
	lappend res [$obj _is_a IDL:operations:1.0]
	lappend res [$obj _is_a IDL:foobar:1.0]
	set res
    } {1 0}
    test operations-8.2 {_non_existent builtin} {
	$obj _non_existent
    } {0}
    test operations-8.3 {_is_equivalent builtin} {
	unset res
	lappend res [$obj _is_equivalent $obj]
	lappend res [$obj _is_equivalent 0]
    } {1 0}

    test operations-9.1 {catching user exception} {
	catch {
	    $obj DontCallMe
	} res
	set res
    } {IDL:Oops:1.0 {what {I said, don't call me!}}}

    test operations-10.1 {get diamond structure} {
	global diamond
	array set diamond [$obj getdiamond]
	expr 1
    } {1}
    test operations-10.2 {diamond object identities} {
	global diamond
	unset res
	lappend res [$diamond(a) _is_a IDL:diamonda:1.0]
	lappend res [$diamond(a) _is_a IDL:diamondb:1.0]
	lappend res [$diamond(a) _is_a IDL:diamondc:1.0]
	lappend res [$diamond(a) _is_a IDL:diamondd:1.0]

	lappend res [$diamond(b) _is_a IDL:diamonda:1.0]
	lappend res [$diamond(b) _is_a IDL:diamondb:1.0]
	lappend res [$diamond(b) _is_a IDL:diamondc:1.0]
	lappend res [$diamond(b) _is_a IDL:diamondd:1.0]

	lappend res [$diamond(c) _is_a IDL:diamonda:1.0]
	lappend res [$diamond(c) _is_a IDL:diamondb:1.0]
	lappend res [$diamond(c) _is_a IDL:diamondc:1.0]
	lappend res [$diamond(c) _is_a IDL:diamondd:1.0]

	lappend res [$diamond(d) _is_a IDL:diamonda:1.0]
	lappend res [$diamond(d) _is_a IDL:diamondb:1.0]
	lappend res [$diamond(d) _is_a IDL:diamondc:1.0]
	lappend res [$diamond(d) _is_a IDL:diamondd:1.0]
    } {1 0 0 0 1 1 0 0 1 0 1 0 1 1 1 1}
    test operations-10.3 {diamond operations} {
	global diamond
	unset res
	lappend res [$diamond(a) opa]

	lappend res [$diamond(b) opa]
	lappend res [$diamond(b) opb]

	lappend res [$diamond(c) opa]
	lappend res [$diamond(c) opc]

	lappend res [$diamond(d) opa]
	lappend res [$diamond(d) opb]
	lappend res [$diamond(d) opc]
	lappend res [$diamond(d) opd]
    } {opa opa opb opa opc opa opb opc opd}
    test operations-10.4 {object references within structure} {
	global diamond
	unset res
	lappend res [[lindex $diamond(abcd) 0] opa]
	lappend res [[lindex $diamond(abcd) 1] opb]
	lappend res [[lindex $diamond(abcd) 2] opc]
	lappend res [[lindex $diamond(abcd) 3] opd]
    } {opa opb opc opd}
    test operations-10.5 {squeezing diamond through object} {
	global diamond
	unset res
	$obj dup2 $diamond(a) o1
	$obj dup2 $diamond(b) o2
	$obj dup2 $diamond(c) o3
	$obj dup2 $diamond(d) o4

	lappend res [$o1 opa]

	lappend res [$o2 opa]
	lappend res [$o2 opb]

	lappend res [$o3 opa]
	lappend res [$o3 opc]

	lappend res [$o4 opa]
	lappend res [$o4 opb]
	lappend res [$o4 opc]
	lappend res [$o4 opd]
    } {opa opa opb opa opc opa opb opc opd}
} out

if {[string first noexec $argv] == -1} {
    kill $server
}

if {$out != ""} {
    puts $out
}