######################################################################
# @(#)tcl8.tcl 1.7 3/28/01
#
# Windows EAI tcl interpreter/tcl version 8 routines
#
# Copyright (C) 2004 Electronic Data Systems Corporation.  All Rights Reserved.
#
#######################################################################


# Error check (these are only for windows and tcl version 8)
if {[utlSysname] != "MSWindows" || ![utlTclVersionAt 8]} {
	return
}


######################################################################
# Puts tries to write to a channel.  This overrides it so that it
# instead goes to the console, when appropriate.

global define
if {![info exists define(puts)]} {
	set define(puts) 1
	rename puts tcl_puts
}

proc puts args {

	# Determine whether this goes to the console or not
	if {[llength $args] == 1} {
		set bUseConsole 1
		set sText [lindex $args 0]
	} else {
		set Channel [lindex $args 0]
		set sText [lindex $args 1]
		if {$Channel == "stderr" || $Channel == "stdout"} {
			set bUseConsole 1
		} else {
			set bUseConsole 0
		}
	}

	# Call the appropriate binary command
	if {$bUseConsole} {
		console_puts $sText
	} else {
		set sCommand "tcl_puts $args"
		eval $sCommand
	}
}


######################################################################
# Tcl 8 implimentation of fileproc
# NOTE: No longer needed; replaced by faster binary version.
# Available for testing purposes only as "fileproc2".
#
# args = {pattern1 code1 pattern2 code2 ...}
#
# Reads each line of the open file specified by "fileid"
# and matches (glob style) the line against each "pattern"; if
# the match succeeds, executes the corresponding "code".
# The value of "linevar" is the name of the variable which is
# set to each read line; this variable can be used in "code".

proc fileproc2 {fileid linevar args} {
	global errorInfo errorCode

	upvar $linevar line
	while {[gets $fileid line] >= 0} {
		foreach {pattern code} $args {
			if {[string match $pattern $line]} {
				set code [catch {uplevel $code} string]

				# Deal with error codes
				if {$code == 1} {
					# Error; "string" describes the problem
					return -code error -errorinfo $errorInfo -errorcode $errorCode $string
				} elseif {$code == 2} {
					# return invoked; "string" contains return value
					return -code return $string
				} elseif {$code == 3} {
					# break invoked
					return
				} elseif {$code > 4} {
					# Specially-defined exception
					return -code $code $string
				}

				break
			}
		}
	}
}


######################################################################
# filesearch
#
# Reads the open file specified by "fileid"
# until it finds a line containing "string".
# Returns the rest of the line, starting with "string".
# Returns the empty string if "string" is not found.

proc filesearch {fileid string} {
	set result ""
	while {[gets $fileid line] >= 0} {
		if {[regexp .*($string.*) $line _ result]} {
			break
		}
	}
	return $result
}


######################################################################
# Tcl 8 implimentation of readbin
# NOTE: binary version is obsolete; this is now the real version
# and eventually needs to be moved and made available for unix.
#
# Accesses the open file specified by "fileid" at position "pos".
# Reads a number of binary bytes and converts them to a string,
# according to "type"; returns this string. 
# Returns the empty string in case of error.
#
# NOTE: for all types other than 1 the command must be executed on
# a platform similar to the one where the file was created.
# Here "similar" means (a) same data size, and (b) same endian-es.

# To do: check data sizes and endian-es for all supported platforms

proc readbin {fileid pos {type 1}} {
	global tcl_platform

	# Set binary encoding, save original
	set OriginalEncoding [fconfigure $fileid -encoding]
	fconfigure $fileid -encoding binary

	# Do the scan
	set result ""
	seek $fileid $pos
	switch $type {
		1 {		# unsigned char
			binary scan [read $fileid 1] c result
			if {![eof $fileid]} {
				if {$result < 0} {incr result 256}
			}
		}

		2 {		# short
			switch $tcl_platform(machine) {
				intel   {binary scan [read $fileid 2] s result}
				default {binary scan [read $fileid 2] S result}
			}
		}

		3 {		# int
			switch $tcl_platform(machine) {
				intel   {binary scan [read $fileid 4] i result}
				default {binary scan [read $fileid 4] I result}
			}
		}

		4 {		# float
			switch $tcl_platform(machine) {
				default {binary scan [read $fileid 4] f result}
			}
		}

		5 {		# double
			switch $tcl_platform(machine) {
				default {binary scan [read $fileid 8] d result}
			}
		}

		default {utlError "illegal type for readbin"}
	}

	# Reset the original encoding for of the channel
	fconfigure $fileid -encoding $OriginalEncoding

	return $result
}


######################################################################
# Tcl 8 implimentation of dde_execute and dde_request
#
# NOTE: The "-timeout" option currently does not work and is simply
# ignored.
 
proc dde_execute args {
	dbg {>dde_execute: $args}

	set newargs ""
	set skipnext 0
	foreach arg $args {
		if {$skipnext} {
			set skipnext 0
		} elseif {$arg == "-timeout"} {
			set skipnext 1
		} else {
			if {[regexp {^\[} $arg]} {
				set arg [list $arg]
			} elseif [catch {set nArgLength [llength $arg]}] {
				set arg [list $arg]
			} elseif {$nArgLength > 1} {
				set arg [list $arg]
			}
			set newargs [concat $newargs $arg]
		}
	}
	set newargs [rtiencode DECODE $newargs]
	dbg {altered args: $newargs}
	eval [concat dde execute $newargs]
	dbg {<dde_execute}
}

proc dde_request args {
	set newargs ""
	set skipnext 0
	foreach arg $args {
		if {$skipnext} {
			set skipnext 0
		} elseif {$arg == "-timeout"} {
			set skipnext 1
		} else {
			if {[regexp {^\[} $arg]} {
				set arg [list $arg]
			}
			set newargs [concat $newargs $arg]
		}
	}
	dbg {dde request $newargs}
	set newargs [rtiencode DECODE $newargs]
	eval [concat dde request $newargs]
}


######################################################################
# This routine is called explicitly (i.e., it is assumed to be 
# defined) by some packages like TK.  It looks for an init script
# with a given name and sources it.  In the process, it also sets up
# the values of some globals.
#
# The EAI version of this routine will look for the file in:
# 1) A directory in the lib directory with the same name as the
# package.
# 2) Directly in the lib directory.
 
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
	upvar #0 $varName global_library_var
	global PVDIR
	dbg {>tcl_findLibrary: $basename $version $patch $initScript $enVarName $varName}

	set libpath {}
	lappend libpaths "$PVDIR/lib/$basename"
	lappend libpaths "$PVDIR/lib"
	foreach libpath $libpaths {
		set initScriptFullPath "$libpath/$initScript"
		dbg {Checking for init script at $initScriptFullPath}
		if {[file exists $initScriptFullPath]} {
			set global_library_var $libpath		
			if {[catch {uplevel #0 [list source $initScriptFullPath]} msg]} {
				utlError "Init script for $basename failed:\n$msg"
			}
			dbg {<tcl_findLibrary: found library at $libpath}
			return
		}
	}

	# It was not found if we reach this point
	utlError "Could not find init script for $basename"
}