# This file contains support code for the Brazil test suite.  It is
# normally sourced by the individual files in the test suite before
# they run their tests.  This improved approach to testing was designed
# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-2001 Sun Microsystems, Inc.
#
# SCCS: @(#) defs 2.1 02/10/01 16:37:36

if {![info exists VERBOSE]} {
    set VERBOSE 0
}
if {![info exists TESTS]} {
    set TESTS {}
}

proc setupJavaPackage {} {
    global errorInfo

    # Cannot use TCL_CLASSPATH because some of the code (in both tcl and
    # Java) uses Class.forName(), which won't go through the TclClassLoader
    # to find the class we are referencing.  Instead the CLASSPATH has
    # to be setup before starting the JVM because the JVM doesn't pick up
    # changes to the CLASSPATH variable after the fact.  

    set classes [file join [pwd] classes]

    if {[catch {package require java}]} {
	error "Unable to find the java package. Skipping entire test.:\n$errorInfo"
    }

    if {[catch {
	java::call Class forName sunlabs.brazil.server.Server
	java::call Class forName tests.TestServer
    }]} {
	puts stderr ""
	puts stderr "Note:"
	puts stderr "CLASSPATH must contain \"$classes\" to run tests"
	puts stderr "since child processes do not inherit CLASSPATH of jaclsh"
	exit 1
    }
}

setupJavaPackage

#
# Global variables used when creating a Brazil server via the "server"
# test command.  These variables will contain the hostname and port of the
# server that was created.
#
set hostname [[java::call java.net.InetAddress getLocalHost] getHostName]
set hostaddr [[java::call java.net.InetAddress getLocalHost] getHostAddress]
set port 2048


#
# test --
#
#   This procedure runs a test and prints an error message if the
#   test fails.  If VERBOSE has been set, it also prints a message
#   even if the test succeeds.  The test will be skipped if it
#   doesn't match the TESTS variable, or if one of the elements
#   of "constraints" turns out not to be true.
#
# Synopsis:
#   test <name> <description> [<constraints>] <script> <answer>
#
# Arguments:
#   <name>	    Name of test, in the form "foo-1.2".
#
#   <description>   Short textual description of the test, to help humans
#		    understand what it does.
#
#   <constraints>   A list of one or more keywords, each of which modifies
#		    the test or treatment of results, as decribed below.
#		    The default value is {}.
#
#   <script>	    Script to run to carry out the test.  It is run in the
#		    global context and it must produce a result that can be
#		    compared to the expected answer.
#
#   <answer>	    Expected result from above script.
#
# Constraints:
#   The constraints modify how the test is carried out.  Some constraints
#   may even change whether the test is even run.  Multiple constraints can
#   be specified and they will compose.
#
#   regexp	The <answer> is not the literal string expected but instead
#		a regexp pattern that the result must match.
#
#   lines	The <answer> is not the literal string expected but instead
#		a sequence of lines.  The result is also treated as a
#		sequence of lines.  Each line in the <answer> must appear
#		as one of the lines in the result and the order that lines
#		appear in the <answer> must match the order that they appear
#		in the result.
#		When both "lines" and "regexp" are specified, then each
#		line in the <answer> is treated as a regexp pattern and the
#		above rules still apply.
#
proc test {name description script answer args} {
    global VERBOSE TESTS testConfig

    if {[string compare $TESTS ""] != 0} {
	set ok 0
	foreach test $TESTS {
	    if {[string match $test $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    return
	}
    }
    set i [llength $args]

    if {$i == 0} {
	set constraints {}
	# Empty body
    } elseif {$i == 1} {
	# "constraints" argument exists;  shuffle arguments down, then
	# make sure that the constraints are satisfied.

	set constraints $script
	set script $answer
	set answer [lindex $args 0]
    } else {
	error "wrong # args: must be \"test name description ?constraints? script answer\""
    }

    foreach item $constraints {
	if {$item == "regexp"} {
	    set constraint(regexp) 1
	} elseif {$item == "lines"} {
	    set constraint(lines) 1
	} elseif {![info exists testConfig($constraint)]
		|| !$testConfig($constraint)} {
	    if {$VERBOSE} {
		puts stdout "++++ $name SKIPPED"
		flush stdout
	    }
	    return
	}
    }

    set code [catch {uplevel $script} result]

    if {$code != 0} {
	test_print $name $description $constraints $script $code $result
    } elseif {[test_compare $answer $result constraint]} {
	if {$VERBOSE} {
	    if {$VERBOSE > 0} {
		test_print $name $description $constraints $script \
		    $code $result
	    }
	    puts stdout "++++ $name PASSED"
            flush stdout
	}
    } else { 
	test_print $name $description  $constraints $script \
		$code $result
	puts stdout "---- Result should have been:"
	puts stdout "$answer"
	puts stdout "---- $name FAILED"
        flush stdout
    }
}

proc test_print {name description constraints script code answer} {
    global errorCode

    puts stdout "\n"
    puts stdout "==== $name $description {$constraints}"
    puts stdout "==== Contents of test case:"
    puts stdout "$script"
    if {$code != 0} {
	if {$code == 1} {
	    puts stdout "==== Test generated error:"
	    puts stdout $answer
	} elseif {$code == 2} {
	    puts stdout "==== Test generated return exception;  result was:"
	    puts stdout $answer
	} elseif {$code == 3} {
	    puts stdout "==== Test generated break exception"
	} elseif {$code == 4} {
	    puts stdout "==== Test generated continue exception"
	} else {
	    puts stdout "==== Test generated exception $code;  message was:"
	    puts stdout $answer
	}
	if {[lindex $errorCode 0] == "JAVA"} {
	    [lindex $errorCode 1] printStackTrace
	}
    } else {
	puts stdout "==== Result was:"
	puts stdout "$answer"
    }
    flush stdout
}

proc test_compare {expected result constraintsName} {
    upvar $constraintsName constraints

    if {[info exists constraints(lines)]} {
	unset constraints(lines)

	set result [split $result "\n"]
	foreach line [split $expected "\n"] {
	    if {$line == ""} {continue}
	    set found 0
	    for {set i 0} {$i < [llength $result]} {incr i} {
		if {[test_compare $line [lindex $result $i] constraints]} {
		    set found 1
		    break
		}
	    }
	    if {$found == 0} {
		return 0
	    }
	    set result [lrange $result $i end]
	}
	return 1
    } elseif {[info exists constraints(regexp)]} {
	return [regexp $expected $result]
    } else {
	return [expr {[string compare $expected $result] == 0}]
    }
}

proc makeFile {name contents} {
    set fd [open $name w]
    puts -nonewline $fd $contents
    close $fd
}

#
# geturl --
#
#   Issues an HTTP request and returns the result.
#
# Synopsis:
#   geturl [-all] <url> [<headers>]
#
# Arguments:
#   -all	Causes this procedure to return the entire HTTP response,
#		both the headers and the content.  Normally, only the content
#		is returned.
#
#   <url>	The fully-specified url, of the form
#		"http://www.sunlabs.com/index.html".
#
#   
#
proc geturl {args} {
    set all 0
    if {[lindex $args 0] == "-all"} {
	set all 1
	set args [lrange $args 1 end]
    }
    set url [lindex $args 0]
    set headers [lindex $args 1]
    set http [java::new {sunlabs.brazil.util.http.HttpRequest String} $url]
    foreach {name value} $headers {
	$http setRequestHeader $name $value
    }
    java::try {
	set in [$http getInputStream]
	set headers ""
	if {$all} {
	    set h [java::field $http responseHeaders]
	    for {set i 0} {$i < [$h size]} {incr i} {
		append headers "[$h getKey $i]: [$h {get int} $i]\n"
	    }
	    append headers "\n"
	}
	set out [java::new java.io.ByteArrayOutputStream]
	$in copyTo $out
	$http close
	return "$headers[$out toString]"
    } catch {Exception e} {
        $http close
	return ""
    }
}
    
#
# Socket --
#
#   Create a Java socket to the specified host and port.  This command
#   exists because the tcl "socket" command has not yet been implemented
#   for jaclsh.
#
#   "writesock" and "readsock" can be used to write and read from the 
#   returned socket object.  Tcl's "puts" and "read" only operate on
#   Tcl file objects.
#
#   This procedure is used in testing to talk to an instance of a 
#   Brazil server and issue and HTTP request.
#
# Synopsis:
#   Socket <host> <port>
#
# Arguments:
#   <host>	Domain-style name such as www.sunlabs.com or a numerical IP
#		address such as 127.0.0.1.
#
#   <port>	Integer port number.
#
proc Socket {host port} {
    set addr [java::call java.net.InetAddress getByName $host]
    set s [java::new {java.net.Socket java.net.InetAddress int} $addr $port]
    return $s
}

#
# writesock --
#
#   Write the string to the socket and then flush the socket.
#
# Synopsis:
#   writesock <sock> <string>
#
# Arguments:
#   <sock>	A Java socket object, such as that returned by the "Socket"
#		procedure.
#
#   <string>	The string to write.
#
proc writesock {sock string} {
    set a [[java::new String $string] getBytes]
    set out [$sock getOutputStream]
    $out {write byte[]} $a
    $out flush
}

#
# readsock --
#
#   Reads from the socket and returns the bytes read.  
#
# Synopsis:
#   readsock <sock> [<count>]
#
# Arguments:
#   <sock>	A Java socket object, such as that returned by the "Socket"
#		procedure.
#
#   <count>	The number of bytes to read.  Exactly that many bytes will
#		be read unless end of file is encountered earlier.  If
#		not specified, it defaults to reading as many bytes as
#		possible up to end of file.
#
proc readsock {sock {count -1}} {
    if {$count < 0} {
	set count 1000000
    }
    set in [$sock getInputStream]
    set s [java::new StringBuffer]
    while {$count > 0} {
	set ch [$in read]
	if {$ch < 0} {
	    break
	}
	$s {append char} [format %c $ch]
    }
    return [$s toString]
}
	
#
# server --
#
#   Create a Brazil Server object.  This object can be activated and made
#   into a running Brazil server by calling the "start" method of the object.
#
#   This procedure will automatically pick the port to use by finding an
#   unused port, and store the selected port number in the global variable
#   "port".
#
# Synopsis:
#   server [<handler>] [<props>]
#
# Arguments:
#   <handler>	The name of the main handler for the server.  Defaults to
#		"tests.TestHandler".
#
#   <props>	The server properties.  Either a Java Properties object
#		or a tcl name-value list.  Defaults to {mime.html text/html}.
#
# Server Options:
#   The server object created is actually a tests.TestServer object.  In
#   addition to the standard methods and fields provided by a Brazil server
#   object, the following method can be invoked for testing purposes.
#
#   toString	Returns a string representation of the log.  All messages
#		logged are saved so they can be examined when testing to
#		check if the correct behavior happened.  Log messages are
#		saved in a simplified form compared with what is printed out
#		by the standard Brazil server.  The easiest way to learn how
#		to use the log is to experiment or examine some already
#		written tests.
#		
proc server {{handler tests.TestHandler} {props {}}} {
    global port hostname

    if {[isobject $handler] || ([llength $handler] > 1)} {
	set props $handler
	set handler tests.TestHandler
    }

    if {[isobject $props] == 0} {
	if {[llength $props] == 0} {
	    set props {mime.html text/html}
        }
	set props [hash new $props]
    }
    set port 2048
    while {1} {
	if {[catch {java::new java.net.ServerSocket $port} listen] == 0} {
	    break
	}
	incr port
    }
    set server [java::new tests.TestServer $listen $handler $props]

    java::field $server {hostName sunlabs.brazil.server.Server} $hostname

    return $server
}

proc isobject {str} {
    return [expr {[catch {$str getClass}] == 0}]
}

#
# request --
#
#   Create a Brazil Request object, used when invoking the "respond" method
#   of a Handler object directly to test a Handler in isolation.  
#
#   Test code does not need to create Request objects when using the
#   "geturl" procedure, which is used to test a running Server.
#
# Synopsis:
#   request <server> <url> [<headers>] [<post>]
#
# Arguments:
#   <server>	A server object returned by the "server" procedure.
#
#   <url>	The URL that the request object will see.  It may be of the
#		form "/index.html" or "GET /index.html HTTP/1.0".  If the
#		first form is seen, the method and HTTP protocol level
#		will be filled in automatically.  The automatically
#		chosen method is "GET" unless <post> data was provided, in
#		which case the automatically chosen method is "POST".
#
#   <headers>	A tcl name-value list making up the HTTP request headers
#		that the request object will see.  Defaults to {}.  If
#		<post> data was provided and "Content-Length" was not present
#		in the headers, then the "Content-Length" will be
#		automatically provided.
#
#   <post>	Post data for the HTTP request.  Defaults to nothing (no post
#		data).
#
proc request {server url {headers {}} {post ""}} {
    set method GET
    if {$post != ""} {
	set method POST
    }
    set str "$method $url HTTP/1.0\r\n"
    if {[llength $url] > 1} {
	set str "$url\r\n"
    }
    foreach {name value} $headers {
	if {[string tolower $name] == "content-length"} {
	    set length $value
	}
	append str "$name: $value\r\n"
    }
    if {($post != "") && ![info exists length]} {
	append str "Content-Length: [string length $post]\r\n"
    }
    append str "\r\n"
    append str $post

    return [java::new sunlabs.brazil.server.TestRequest $server $str]
}

#
# handler --
#
#   Convenience method to create a Brazil Handler object and then call its
#   "init" method.
#
# Synopsis:
#   handler <name> <server> [<prefix>]
#
# Arguments:
#   <name>	The class name for the new handler.
#
#   <server>	The server object, used when calling the Handler's "init"
#		method.
#
#   <prefix>	The prefix for this Handler, used when calling the Handler's
#		"init" method.  Defaults to "".  If a prefix is specified but
#		it doesn't end with '.', a '.' is appended to the prefix.
#
proc handler {name server {prefix ""}} {
    if {($prefix != "") && ([string match *. $prefix] == 0)} {
	append prefix .
    }
    set h [java::new $name]
    $h init $server $prefix
    return $h
}

#
# template --
#
#   Creates a server running the specified templates and sends a request
#   to that server.  The results of the request are returned so that they can
#   be examined by the testing code.
#
# Synopsis:
#   template <names> <body> <config> [<name> <value> ...]
#
# Arguments:
#   <names>	A list of the names of the templates.  The first name in
#		the list is the Primary Template.  
#
#   <body>	The HTML fragment that will be processed by the specified
#		templates.
#
#   <config>	An optional name-value list specifying additional server
#		properties.
#
#   <name> <value>	Additional optional arguments as follows:
#
#   query <string>	<string> is a query string to pass to the server
#			when issuing the request that causes the given HTML
#			fragment to be processed.
#
#   headers <list>	<list> is a name-value list of HTTP headers to pass
#			to the server when issuing the request that causes
#			the given HTML fragment to be processed.
#
#   prefix <string>	<string> is the template's prefix (hr.prefix in the template)
#
# Results:
#   The return value is a name-value list that can be used by the
#   "array set" command.  The name elements and their associated values are:
#
#   result	The result of processing the HTML fragment <body> with the
#		specified templates.
#
#   log		The server log for the request that generated the result.
#
#   template	The instance of the Primary Template that processed the
#		request, so the testing code can examine its member variables.
#   
proc template {names body {config {}} args} {
    set name index.html
    
    set prefix ""
    set query ""
    set headers {}

    foreach {var value} $args {
	set $var $value
    }
    
    set f [open $name w]
    puts -nonewline $f $body
    close $f

    # Add a few things to the provided config to make it work.

    set TH sunlabs.brazil.template.TemplateHandler

    lappend config "mime.html" "text/html"
    if {$prefix == ""} {
	lappend config "templates" $names
    } else {
	lappend config "${prefix}.class" $TH
	lappend config "${prefix}.templates" $names
	set TH $prefix
    }

    set s [server $TH $config]	;# This could change ::port as a side-effect

    set url http://localhost:$::port/$name
    if {$query != ""} {
	append url ? $query
    }
    $s start
    set result [geturl $url $headers]
    $s close
    set log [$s toString]
    
    set v [java::call sunlabs.brazil.session.SessionManager getSession common template [java::null]]
    set v [java::cast java.util.Vector $v]
    set template ""
    catch {
	set template [$v elementAt 0]
	set template [java::cast [lindex $names 0] $template]
    }
    return [list result $result log $log template $template server $s]
}

# "array set" doesn't appear to be object aware.  It is copying the string
# value of the java objects into the array, not the java objects themselves.
# The java objects are then losing all references and disappearing, leaving
# the array elements naming non-existent objects.

rename array array.1

proc array {args} {
    switch -- [lindex $args 0] {
	"set" {
	    upvar [lindex $args 1] array
	    foreach {name value} [lindex $args 2] {
		set array($name) $value
	    }
	}
	"get" {
	    set list {}
	    upvar [lindex $args 1] array
	    foreach name [array.1 names array] {
		lappend list $name $array($name)
	    }
	    return $list
	}
	default {
	    return [uplevel array.1 $args]
 	}	
    }
}

#
# squish --
#
#   Takes an HTML result and squishes out the extra space and blank lines
#   that are artifacts of evaluating BSL commands.  The result is also 
#   formatted with an extra newline at the beginning and end so it can
#   easily be compared using the test procedure.  Simplest way to understand 
#   previous statement is to examine uses of this procedure in test code.
#
# Arguments:
#   <str>	The HTML result to format.
#
proc squish {str} {
    set result ""
    foreach line [split $str "\n"] {
	append result [string trim $line] "\n"
    }
    set str "\n${result}\n"
    while {[regsub -all "\[\r\n]\[\r\n]" $str "\n" str]} {}
    return $str
}

#
# methods --
#
#   Returns the list of signatures for the public methods declared by the
#   given class.  "java::info methods" returns all the public methods
#   declared by the class and all its parents, which is too much
#   information.
#
# Arguments:
#   <name>	The class name.
#
proc methods {name} {
    set list {}
    set class [java::call Class forName $name]
    foreach m [[$class getDeclaredMethods] getrange] {
	set n [$m getModifiers]
	if {[java::call java.lang.reflect.Modifier isPublic $n]} {
	    set sig {}
	    lappend sig [$m getName]
	    foreach arg [[$m getParameterTypes] getrange] {
		lappend sig [$arg getName]
	    }
	    lappend list $sig
	}
    }
    return $list
}
	
#
# fields --
#
#   Returns the name-value list of the public fields and their values
#   in the given object, sorted by the names of the fields.
#
# Synopsis:
#   fields <obj> [<fields>]
#   
# Arguments:
#   <obj>	A Java object.
#
#   <fields>	The list of the names of the fields to get.  If not
#		specified, gets all the public fields.
#
proc fields {obj {fields {}}} {
    if {[llength $fields] == 0} {
	set fields [java::info fields $obj]
    }
    set list {}

    foreach name [lsort $fields] {
	set name [string range $name 0 end]
	set value [java::call String {valueOf Object} [java::field $obj $name]]
	lappend list $name
	lappend list $value
    }
    return $list
}

proc suppressIO {} {
    set out [java::field System out]
    set err [java::field System err]
    set tmp [java::new java.io.ByteArrayOutputStream]
    set tmp [java::new java.io.PrintStream $tmp]
    java::call System setOut $tmp
    java::call System setErr $tmp

    return [list $out $err]
}

proc restoreIO {list} {
    java::call System setOut [lindex $list 0]
    java::call System setErr [lindex $list 1]
}

#
# hash --
#
#   Manipulate Java Properties objects in the same way you can manipulate
#   tcl arrays.
#
# Synopsis:
#   hash new [<list>]
#   hash get <object> [<pattern>]
#   hash set <object> [<list>]
#
# Arguments:
#   <list>	A tcl name-value list of the form {name1 val1 name2 val2 ...}.
#   <object>	A Java Properties object.
#   <pattern>	A glob pattern.
#
# Hash New:
#   Create a new Properties object.  If <list> is specified, the name-value
#   pairs in the list are used to initialize the new Properties object.
#
# Hash Get:
#   Returns a tcl name-value list representing the data in the Properties
#   <object>.  If <pattern> is not specified, then all the elements of the
#   Properties are included in the result.  If <pattern> is specified, then
#   only those elements whose names match the <pattern> are included.
#
# Hash Set:
#   Sets the values of one or more elements in the Properties <object>.
#   The <object> may already have elements in it.
#
proc hash {cmd args} {
    switch -- $cmd {
	"new" {
	    set p [java::new java.util.Properties]
	    eval hash set $p $args
	    return $p
	}
	"get" {
	    set obj [lindex $args 0]
	    set pattern [lindex $args 1]
	    if {$pattern == ""} {
		set pattern "*"
	    }
	    set list {}
	    set keys [$obj keys]
	    set values [$obj elements]
	    while {[$keys hasMoreElements]} {
		set key [[$keys nextElement] toString]
		set value [[$values nextElement] toString]
	   	if {[string match $pattern $key]} {		
		    lappend list $key $value
		}
	    }
	    return $list
	}
	"set" {
	    set obj [lindex $args 0]
	    set list [lrange $args 1 end]
	    if {[llength $list] == 1} {
		set list [lindex $list 0]
	    }
	    foreach {name value} $list {
		$obj put $name $value
	    }
	    return $obj
	}
	default {
	    error "unknown command"
	}
    }
}

#
# makearray --
#
#   Convert the serialized form of a Properties object to a tcl array.
#
proc makearray {arrayName propdata} {
    upvar $arrayName array

    catch {unset array}

    set p [java::new java.util.Properties]
    $p load [java::new java.io.StringBufferInputStream $propdata]
    array set array [hash get $p]
}

