###############################################################################
#
# init.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Interpreter Initialization File
#
# Copyright (c) 2007-2012 by Joe Mistachkin. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
#
###############################################################################
#
# NOTE: Use our own namespace here because even though we do not directly
# support namespaces ourselves, we do not want to pollute the global
# namespace if this script actually ends up being evaluated in Tcl.
#
namespace eval ::Eagle {
#
# NOTE: This is the procedure that detects whether or not we are
# running in Eagle (otherwise, we are running in vanilla Tcl).
# This procedure must function correctly in both Tcl and Eagle
# and must return non-zero only when running in Eagle.
#
proc isEagle {} {
#
# NOTE: Nothing too fancy or expensive should be done in here. In
# theory, use of this routine should be rare; however, in
# practice, this routine is actually used quite a bit (e.g.
# by the test suite).
#
return [expr {[info exists ::tcl_platform(engine)] && \
[string compare -nocase eagle $::tcl_platform(engine)] == 0}]
}
#
# NOTE: This is the procedure that detects whether or not we are
# running on Windows (otherwise, we are running on some flavor
# of Unix). This procedure must function correctly in both Tcl
# and Eagle and must return non-zero only when on Windows.
#
proc isWindows {} {
return [expr {[info exists ::tcl_platform(platform)] && \
$::tcl_platform(platform) eq "windows"}]
}
#
# NOTE: This procedure should return non-zero if and only if only there
# is currently an interactive user that can respond to prompts and
# other requests for input.
#
proc isInteractive {} {
#
# TODO: Is more complex checking required here?
#
return [expr {[info exists ::tcl_interactive] && $::tcl_interactive}]
}
proc haveGaruda { {varName ""} } {
#
# NOTE: Check for a variable name to place the Garuda package Id into.
#
if {[string length $varName] > 0} then {
upvar 1 $varName packageId
}
#
# NOTE: Is the Eagle Package for Tcl (Garuda) available? This check
# is different in Eagle and Tcl.
#
if {[isEagle]} then {
return [expr {[llength [info commands tcl]] > 0 && [tcl ready] && \
[catch {tcl eval [tcl master] {package present Garuda}}] == 0 && \
[catch {tcl eval [tcl master] {garuda packageid}} packageId] == 0}]
} else {
return [expr {[catch {package present Garuda}] == 0 && \
[catch {garuda packageid} packageId] == 0}]
}
}
proc isTclThread { name } {
#
# NOTE: For now, this check only works in Eagle.
#
set result false
if {[isEagle]} then {
catch {
if {[llength [info commands tcl]] > 0 && [tcl ready] && \
[lsearch -exact -- [tcl threads] $name] != -1} then {
#
# NOTE: The name specified by the caller appears in the
# list of Tcl threads for this Eagle interpreter.
#
set result true
}
}
}
return $result
}
#
# NOTE: This is the procedure that detects whether or not we are
# running in Eagle on Mono (otherwise, we are running in Tcl
# or in Eagle on .NET). This procedure must function correctly
# in both Tcl and Eagle and must return non-zero only when
# running in Eagle on Mono.
#
proc isMono {} {
return [expr {[info exists ::eagle_platform(runtime)] && \
[string compare -nocase mono $::eagle_platform(runtime)] == 0}]
}
#
# NOTE: This procedure returns non-zero if the specified file names refer
# to the same file, using the most robust method available for the
# script engine and platform.
#
proc isSameFileName { fileName1 fileName2 } {
if {[isEagle]} then {
return [file same $fileName1 $fileName2]
} else {
if {[isWindows]} then {
return [string equal -nocase $fileName1 $fileName2]
} else {
return [string equal $fileName1 $fileName2]
}
}
}
proc getEnvironmentVariable { name } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
return [expr {[info exists ::env($name)] ? $::env($name) : ""}]
}
proc combineFlags { flags1 flags2 } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set result [list]
foreach flags [list $flags1 $flags2] {
foreach flag [split $flags ", "] {
set flag [string trim $flag]
if {[string length $flag] > 0} then {
lappend result $flag
}
}
}
return [join $result ,]
}
proc getCompileInfo {} {
#
# NOTE: Return the important compile-time information for use by the
# setup or other callers.
#
return [expr {[isEagle] ? [lappend result \
TimeStamp $::eagle_platform(timeStamp) \
ImageRuntimeVersion $::eagle_platform(imageRuntimeVersion) \
ModuleVersionId $::eagle_platform(moduleVersionId) \
CompileOptions $::eagle_platform(compileOptions)] : ""}]
}
proc getPlatformInfo { name {default ""} } {
#
# NOTE: Return the important platform information for use by the test
# suite or other callers.
#
return [expr {[isEagle] && [info exists ::eagle_platform($name)] && \
[string length [string trim $::eagle_platform($name)]] > 0 ? \
$::eagle_platform($name) : $default}]
}
proc getPluginPath { pattern } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
foreach loaded [info loaded] {
if {[regexp -- $pattern [lindex $loaded end]]} then {
return [lindex $loaded 0]
}
}
return ""
}
proc appendArgs { args } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set result ""; eval append result $args
}
proc lappendArgs { args } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set result [list]; eval lappend result $args
}
proc getDictionaryValue { dictionary name {default ""} {wrap ""} } {
#
# NOTE: Locate the named value we are interested in. The dictionary must
# be a list with an even number of elements in the following format:
#
# <name1> <value1> <name2> <value2> ... <nameN> <valueN>
#
foreach {pairName pairValue} $dictionary {
#
# NOTE: Does this name match the one specified by the caller?
#
if {$pairName eq $name} then {
#
# NOTE: Return the value, optionally wrapped.
#
return [appendArgs $wrap $pairValue $wrap]
}
}
#
# NOTE: Return the default value.
#
return $default
}
proc getColumnValue { row column {default ""} {wrap ""} } {
#
# NOTE: Start with the default value.
#
set result $default
#
# NOTE: Locate the index of the named column we are interested in.
# This requires Tcl 8.5 or Eagle.
#
set index [lsearch -exact -index 0 $row $column]
#
# NOTE: Did we find the column name in the row?
#
if {$index != -1} then {
#
# NOTE: Grab the column value.
#
set result [appendArgs $wrap [lindex [lindex $row $index] end] $wrap]
}
return $result
}
proc getRowColumnValue { varName id column {default ""} {wrap ""} } {
#
# NOTE: Start with the default value.
#
set result $default
#
# NOTE: We need acccess to the result array (from the context of the
# caller).
#
upvar 1 $varName rows
#
# NOTE: Make sure we have the first result row.
#
if {[info exists rows($id)]} then {
#
# NOTE: Grab the entire row we are interested in.
#
set row $rows($id)
#
# NOTE: Grab the value at the specified column.
#
set result [getColumnValue $row $column $default $wrap]
}
return $result
}
proc tqputs { channel string } {
#
# NOTE: If an output channel was provided, use it; otherwise, ignore the
# message.
#
if {[string length $channel] > 0} then {
puts -nonewline $channel $string
}
tqlog $string
}
proc tqlog { string } {
#
# NOTE: If an empty string is supplied by the caller, do nothing.
#
if {[string length $string] > 0} then {
#
# NOTE: *SPECIAL* The special global variable "test_log_queue" is used
# by the [tlog] script library procedure from the test package to
# enable it to emit "queued" data into the test log file prior to
# emitting the string requested by its caller. The only job for
# this procedure is to populate the "test_log_queue" variable for
# later use by the test package.
#
if {[info exists ::test_log_queue]} then {
#
# NOTE: Use the next queued test log entry.
#
set entry [expr {[array size ::test_log_queue] + 1}]
} else {
#
# NOTE: Use the first queued test log entry.
#
set entry 1
}
#
# NOTE: Add the new entry to the test log queue. All entries will be
# sent to the actual test log file the very next time the [tlog]
# command from the test package is executed.
#
set ::test_log_queue($entry) $string
}
return ""
}
proc readFile { fileName } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName RDONLY]
fconfigure $channel -encoding binary -translation binary; # BINARY DATA
set result [read $channel]
close $channel
return $result
}
proc readSharedFile { fileName } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set command [list open $fileName RDONLY]
#
# HACK: Tcl appears to do this by default; however Eagle does not and
# will not. Therefore, manually add the -share option to the
# command if running in Eagle.
#
if {[isEagle]} then {
lappend command 0 file -share readWrite
}
#
# NOTE: Open the file using the command constructed above, configure
# the channel for binary data, and output the data to it.
#
set channel [eval $command]
fconfigure $channel -encoding binary -translation binary; # BINARY DATA
set result [read $channel]
close $channel
return $result
}
proc writeFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName {WRONLY CREAT TRUNC}]
fconfigure $channel -encoding binary -translation binary; # BINARY DATA
puts -nonewline $channel $data
close $channel
return ""
}
proc appendFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName {WRONLY CREAT APPEND}]
fconfigure $channel -encoding binary -translation binary; # BINARY DATA
puts -nonewline $channel $data
close $channel
return ""
}
proc appendLogFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName {WRONLY CREAT APPEND}]
fconfigure $channel -encoding binary -translation \
[expr {[isEagle] ? "protocol" : "auto"}]; # LOG DATA
puts -nonewline $channel $data
close $channel
return ""
}
proc appendSharedFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set command [list open $fileName {WRONLY CREAT APPEND}]
#
# HACK: Tcl appears to do this by default; however Eagle does not and
# will not. Therefore, manually add the -share option to the
# command if running in Eagle.
#
if {[isEagle]} then {
lappend command 0 file -share readWrite
}
#
# NOTE: Open the file using the command constructed above, configure
# the channel for binary data, and output the data to it.
#
set channel [eval $command]
fconfigure $channel -encoding binary -translation binary; # BINARY DATA
puts -nonewline $channel $data; flush $channel
close $channel
return ""
}
proc appendSharedLogFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set command [list open $fileName {WRONLY CREAT APPEND}]
#
# HACK: Tcl appears to do this by default; however Eagle does not and
# will not. Therefore, manually add the -share option to the
# command if running in Eagle.
#
if {[isEagle]} then {
lappend command 0 file -share readWrite
}
#
# NOTE: Open the file using the command constructed above, configure
# the channel for binary data, and output the data to it.
#
set channel [eval $command]
fconfigure $channel -encoding binary -translation \
[expr {[isEagle] ? "protocol" : "auto"}]; # LOG DATA
puts -nonewline $channel $data; flush $channel
close $channel
return ""
}
proc readAsciiFile { fileName } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName RDONLY]
fconfigure $channel -encoding ascii -translation auto; # ASCII TEXT
set result [read $channel]
close $channel
return $result
}
proc writeAsciiFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName {WRONLY CREAT TRUNC}]
fconfigure $channel -encoding ascii -translation auto; # ASCII TEXT
puts -nonewline $channel $data
close $channel
return ""
}
proc readUnicodeFile { fileName } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName RDONLY]
fconfigure $channel -encoding unicode -translation auto; # UNICODE TEXT
set result [read $channel]
close $channel
return $result
}
proc writeUnicodeFile { fileName data } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set channel [open $fileName {WRONLY CREAT TRUNC}]
fconfigure $channel -encoding unicode -translation auto; # UNICODE TEXT
puts -nonewline $channel $data
close $channel
return ""
}
proc getDirResultPath { pattern path } {
#
# NOTE: This should work properly in both Tcl and Eagle.
# Is the result path itself already absolute?
#
if {[file pathtype $path] eq "absolute"} then {
#
# NOTE: Ok, the result path is already absolute.
# Normalize and return it.
#
return [file normalize $path]
} elseif {[file pathtype $pattern] eq "absolute"} then {
#
# NOTE: The pattern refers to an absolute path. Strip
# the final part of the pattern and join it with
# the result path (which we already know is not
# absolute).
#
return [file normalize [file join [file dirname $pattern] $path]]
} else {
#
# NOTE: Neither the result path nor the input pattern
# contain an absolute path; therefore, use the
# current directory to hang the result path on.
#
return [file normalize [file join [pwd] $path]]
}
}
proc addToPath { dir } {
#
# NOTE: This should work properly in both Tcl and Eagle.
# Normalize to an operating system native path.
#
set dir [file nativename $dir]
#
# NOTE: On Windows, use PATH; otherwise (i.e. Unix), use
# LD_LIBRARY_PATH.
#
if {[isWindows]} then {
set name PATH
} else {
set name LD_LIBRARY_PATH
}
#
# NOTE: Make sure the directory is not already in the
# loader search path.
#
if {[info exists ::tcl_platform(pathSeparator)]} then {
set separator $::tcl_platform(pathSeparator)
} elseif {[isWindows]} then {
set separator \;
} else {
set separator :
}
#
# NOTE: Does the necessary environment variable exist?
#
if {[info exists ::env($name)]} then {
#
# NOTE: Grab the value of the environment variable.
#
set value $::env($name)
#
# BUGBUG: Consider exact case only for now.
#
if {[lsearch -exact [split $value $separator] $dir] == -1} then {
#
# NOTE: Append the directory to the loader search path.
# This allows us to subsequently load DLLs that
# implicitly attempt to load other DLLs that are
# not in the application directory.
#
set ::env($name) [join [list $value $dir] $separator]
#
# NOTE: Yes, we altered the search path.
#
return true
}
} else {
#
# NOTE: Create the loader search path with the directory.
#
set ::env($name) $dir
#
# NOTE: Yes, we created the search path.
#
return true
}
#
# NOTE: No, we did not alter the search path.
#
return false
}
proc removeFromPath { dir } {
#
# NOTE: This should work properly in both Tcl and Eagle.
# Normalize to an operating system native path.
#
set dir [file nativename $dir]
#
# NOTE: On Windows, use PATH; otherwise (i.e. Unix), use
# LD_LIBRARY_PATH.
#
if {[isWindows]} then {
set name PATH
} else {
set name LD_LIBRARY_PATH
}
#
# NOTE: Make sure the directory is in the loader search
# path.
#
if {[info exists ::tcl_platform(pathSeparator)]} then {
set separator $::tcl_platform(pathSeparator)
} elseif {[isWindows]} then {
set separator \;
} else {
set separator :
}
#
# NOTE: Does the necessary environment variable exist?
#
if {[info exists ::env($name)]} then {
#
# NOTE: We need to separate the directories in the path
# so that we can selectively remove the one we are
# looking for.
#
set dirs [split $::env($name) $separator]
#
# BUGBUG: Consider exact case only for now.
#
set index [lsearch -exact $dirs $dir]
#
# NOTE: Is the directory in the loader search path?
#
if {$index != -1} then {
#
# NOTE: Remove the directory from the loader search path.
#
set dirs [lreplace $dirs $index $index]
#
# NOTE: Replace the original loader search path with
# our modified one.
#
set ::env($name) [join $dirs $separator]
#
# NOTE: Yes, we altered the search path.
#
return true
}
}
#
# NOTE: No, we did not alter the search path.
#
return false
}
proc execShell { options args } {
set command [list exec]
if {[llength $options] > 0} then {eval lappend command $options}
lappend command --
#
# HACK: Assume that Mono is somewhere along the PATH.
#
if {[isMono]} then {
lappend command mono \
[appendArgs \" [file nativename [info nameofexecutable]] \"]
} else {
lappend command [info nameofexecutable]
}
if {[llength $args] > 0} then {eval lappend command $args}
return [uplevel 1 $command]
}
proc lshuffle { list } {
#
# NOTE: This code for this algorithm was stolen from the Tcl library
# struct package and modified to conform with the Eagle style
# guide.
#
set result $list
for {set length [llength $result]} \
{$length > 1} {lset result $index $element} {
set index [expr {int(rand() * $length)}]
set element [lindex $result [incr length -1]]
lset result $length [lindex $result $index]
}
return $result
}
proc ldifference { list1 list2 } {
set result [list]
foreach element $list1 {
if {[lsearch -exact $list2 $element] == -1} then {
lappend result $element
}
}
foreach element $list2 {
if {[lsearch -exact $list1 $element] == -1} then {
lappend result $element
}
}
return $result
}
proc filter { list script } {
set result [list]
foreach item $list {
if {[uplevel 1 $script [list $item]]} then {
lappend result $item
}
}
return $result
}
proc map { list script } {
set result [list]
foreach item $list {
lappend result [uplevel 1 $script [list $item]]
}
return $result
}
proc reduce { list script } {
set result ""
foreach item $list {
set result [uplevel 1 $script [list $result] [list $item]]
}
return $result
}
if {[isEagle]} then {
###########################################################################
############################ BEGIN Eagle ONLY #############################
###########################################################################
proc isAdministrator {} {
#
# NOTE: Returns non-zero if the logged on user has full administrator
# rights on this machine.
#
return [expr {[info exists ::eagle_platform(administrator)] && \
$::eagle_platform(administrator)}]
}
proc hasRuntimeOption { name } {
#
# NOTE: Returns non-zero if the specified runtime option is set.
#
return [object invoke Interpreter.GetActive HasRuntimeOption $name]
}
proc getPluginFlags { pattern } {
foreach loaded [info loaded] {
set plugin [lindex $loaded end]
if {[regexp -- $pattern $plugin]} then {
return [string map [list , " "] \
[getDictionaryValue [info plugin $plugin] flags]]
}
}
return [list]
}
proc getProcesses { name } {
#
# NOTE: Start with an empty list of process Ids.
#
set result [list]
#
# NOTE: Does the caller want processes matching a specific name
# or all processes on the local machine?
#
if {[string length $name] > 0} then {
#
# NOTE: Get the managed array of processes with matching names.
#
set array [object invoke -alias System.Diagnostics.Process \
GetProcessesByName $name]
} else {
#
# NOTE: Get the managed array of all processes on the local
# machine.
#
set array [object invoke -alias System.Diagnostics.Process \
GetProcesses]
}
#
# NOTE: For each process in the resulting array, grab the Id.
#
for {set index 0} {$index < [$array Length]} {incr index} {
#
# NOTE: Grab the Nth process array element value using the
# accessor method.
#
set process [$array -alias GetValue $index]
#
# NOTE: Add the Id of the process to the result list.
#
lappend result [$process Id]
#
# NOTE: Get rid of the process object, we no longer need it.
# Technically, it is not a requirement to explicitly
# unset variables that contain object references;
# however, it is useful in helping to document the
# code.
#
unset process; # dispose
}
#
# NOTE: Get rid of the managed array of processes, we no longer
# need it.
#
unset array; # dispose
#
# NOTE: Return the list of process Ids, which may be empty.
#
return $result
}
proc waitForProcesses { ids timeout {collect true} } {
#
# NOTE: If requested, run the garbage collector now. This may be
# necessary to successfully wait for processes that are being
# kept alive via runtime callable wrappers for out-of-process
# COM servers (e.g. Excel).
#
if {$collect} then {
debug collect true true
}
#
# NOTE: Wait for each process in the list to exit.
#
foreach id $ids {
#
# NOTE: Get the process object by its Id. If it does not exist,
# this will raise an error.
#
set result [catch {
set process [object invoke -alias System.Diagnostics.Process \
GetProcessById $id]
}]
#
# NOTE: Were we able to grab the process object?
#
if {$result == 0 && [info exists process]} then {
#
# NOTE: Wait a while for the process to exit.
#
$process WaitForExit $timeout
}
#
# NOTE: Get rid of the process (if we actually obtained it to
# begin with).
#
unset -nocomplain process; # dispose
}
}
#
# NOTE: This proc can be used to dynamically compile C# code in a script.
#
proc compileCSharp {
string memory symbols strict resultsVarName errorsVarName args } {
#
# NOTE: Create the C# code provider object (i.e. the compiler).
#
set provider [object create -alias Microsoft.CSharp.CSharpCodeProvider]
#
# NOTE: Create the object that provides various parameters to the C#
# code provider (i.e. the compiler options).
#
set parameters [object create -alias \
System.CodeDom.Compiler.CompilerParameters]
#
# NOTE: Do we not want to persist the generated assembly to disk?
#
if {$memory} then {
$parameters GenerateInMemory true
}
#
# NOTE: Do we want symbols to be generated for the generated assembly?
#
if {$symbols} then {
$parameters IncludeDebugInformation true
}
#
# NOTE: Make sure that the "standard" preprocessor defines match those
# for the platform (i.e. the ones used to compile the Eagle core
# library assembly).
#
set platformOptions [expr { \
[info exists ::eagle_platform(compileOptions)] ? \
$::eagle_platform(compileOptions) : [list]}]
#
# NOTE: Permit extra C# compiler options to be passed via the global
# array element "csharpOptions", if it exists.
#
set csharpOptions [expr { \
[info exists ::eagle_platform(csharpOptions)] ? \
$::eagle_platform(csharpOptions) : [list]}]
if {[llength $platformOptions] > 0 || \
[llength $csharpOptions] > 0} then {
#
# NOTE: Grab the existing compiler options, if any.
#
set compilerOptions [$parameters CompilerOptions]
if {"DEBUG" in $platformOptions} then {
if {[string length $compilerOptions] > 0} then {
append compilerOptions " "
}
append compilerOptions /define:DEBUG
}
if {"TRACE" in $platformOptions} then {
if {[string length $compilerOptions] > 0} then {
append compilerOptions " "
}
append compilerOptions /define:TRACE
}
#
# NOTE: Append the configured extra C# compiler options configured
# via the global array element "csharpOptions", if any.
#
foreach csharpOption $csharpOptions {
if {[string length $compilerOptions] > 0} then {
append compilerOptions " "
}
append compilerOptions $csharpOption
}
#
# NOTE: Reset the compiler options to the pre-existing ones plus the
# extra defines we may have added (above).
#
$parameters CompilerOptions $compilerOptions
}
#
# NOTE: Process any extra compiler settings the caller may have
# provided.
#
foreach {name value} $args {
$parameters -nocase $name $value
}
#
# NOTE: Prepare to transfer the object reference to the caller. We
# must use upvar here because otherwise the object is lost when
# the procedure call frame is cleaned up.
#
upvar 1 $resultsVarName results
#
# NOTE: Attempt to compile the specified string as C# and capture the
# results into the variable provided by the caller.
#
set results [$provider -alias CompileAssemblyFromSource $parameters \
$string]
#
# NOTE: We no longer need the C# code provider object (i.e. the
# compiler); therefore, dispose it now.
#
unset provider; # dispose
#
# NOTE: Fetch the collection of compiler errors (which may be empty).
#
set errors [$results -alias Errors]
#
# NOTE: It is assumed that no assembly was generated if there were
# any compiler errors. Ignore all compiler warnings unless
# we are in strict mode.
#
if {[$errors HasErrors] || ($strict && [$errors HasWarnings])} then {
#
# NOTE: Compilation of the assembly failed.
#
set code Error
#
# NOTE: Prepare to transfer the error messages to the caller.
#
upvar 1 $errorsVarName local_errors
#
# NOTE: How many compile errors?
#
set count [$errors Count]
#
# NOTE: Grab each error object and append the string itself to
# the overall list of errors.
#
for {set index 0} {$index < $count} {incr index} {
#
# NOTE: Get the compiler error object at this index.
#
set error [$errors -alias Item $index]
#
# NOTE: Convert it to a string and append it to the list of
# errors.
#
lappend local_errors [$error ToString]
#
# NOTE: Since the error itself is actually an object, we must
# dispose it.
#
unset error; # dispose
}
} else {
#
# NOTE: Compilation of the assembly succeeded.
#
set code Ok
}
#
# NOTE: We no longer need the collection of compiler errors;
# therefore, dispose it now.
#
unset errors; # dispose
return $code
}
proc matchEnginePublicKeyToken { publicKeyToken } {
return [expr {[string length $publicKeyToken] == 0 || \
$publicKeyToken eq [info engine PublicKeyToken]}]
}
proc matchEngineName { name } {
return [expr {[string length $name] == 0 || \
$name eq [info engine Name]}]
}
proc matchEngineCulture { culture } {
return [expr {[string length $culture] == 0 || \
$culture eq [info engine Culture]}]
}
proc escapeUpdateNotes { notes } {
#
# NOTE: Escape any embedded tab and line-ending characters.
#
return [string map \
[list & &\; \t &htab\; \v &vtab\; \n &lf\; \r &cr\;] $notes]
}
proc unescapeUpdateNotes { notes } {
#
# NOTE: Unescape any embedded tab and line-ending characters.
#
return [string map \
[list &htab\; \t &vtab\; \v &lf\; \n &cr\; \r &\; &] $notes]
}
proc getFetchUpdateArgs { baseUri patchLevel type directory extension } {
#
# NOTE: Initially, set the result to an empty list to indicate
# unrecognized input.
#
set result [list]
#
# NOTE: Make sure the base URI is valid.
#
if {[uri isvalid $baseUri]} then {
#
# NOTE: Make sure the patch level looks valid.
#
if {[regexp -- {^\d+\.\d+\.\d+\.\d+$} $patchLevel]} then {
#
# NOTE: Make sure the directory is either empty or an existing
# valid directory.
#
if {[string length $directory] == 0 || \
[file isdirectory $directory]} then {
#
# NOTE: Make sure the extension is supported.
#
if {$extension eq ".exe" || $extension eq ".rar"} then {
#
# NOTE: Start with the URI components common to all download
# types.
#
set components [list $baseUri releases $patchLevel]
#
# NOTE: Next, figure out what type of download is being
# requested.
#
switch -exact -nocase -- $type {
source -
setup -
binary {
#
# NOTE: Source code, setup, or binary download. This may be
# a RAR or an EXE file. Append the appropriate file
# name and then join all the URI components to form the
# final URI.
#
set fileName [appendArgs \
[info engine] [string totitle $type] $patchLevel \
[expr {[string tolower $type] eq "setup" ? ".exe" : \
$extension}]]
lappend components $fileName
set result [list [eval uri join $components] [file join \
$directory $fileName]]
}
}
}
}
}
}
return $result
}
proc fetchUpdate { baseUri patchLevel type directory } {
#
# NOTE: Figure out the appropriate file extension to download for
# this platform.
#
set extension [expr {[isWindows] ? ".exe" : ".rar"}]
#
# NOTE: Build the necessary arguments for the download.
#
set args [getFetchUpdateArgs $baseUri $patchLevel $type \
$directory $extension]
if {[llength $args] > 0} then {
#
# NOTE: Start trusting ONLY our self-signed SSL certificate.
#
set trusted true
if {[lindex [uri softwareupdates] end] eq "untrusted"} then {
uri softwareupdates true
} else {
set trusted false; # NOTE: Already trusted.
}
try {
#
# NOTE: Download the file from the web site.
#
eval uri download $args; # synchronous.
} finally {
if {$trusted && \
[lindex [uri softwareupdates] end] eq "trusted"} then {
#
# NOTE: Stop trusting ONLY our self-signed SSL certificate.
#
uri softwareupdates false
}
}
#
# NOTE: Return a result indicating what was done.
#
return [appendArgs "downloaded URI " [lindex $args 0] \
" to directory \"" $directory \"]
} else {
return "cannot fetch update, the URI is invalid"
}
}
proc runUpdateAndExit { {automatic false} } {
set directory [file dirname [info nameofexecutable]]
set command [list exec -shell -- \
[file join $directory Hippogriff.exe] -delay 2000]
if {$automatic} then {
eval lappend command -silent true -confirm false
}
eval $command &; exit -force
}
proc getUpdateData { uri } {
#
# NOTE: Start trusting ONLY our own self-signed SSL certificate.
#
set trusted true
if {[lindex [uri softwareupdates] end] eq "untrusted"} then {
uri softwareupdates true
} else {
set trusted false; # NOTE: Already trusted.
}
try {
#
# NOTE: Download the tag file from the web site.
#
return [uri download -inline $uri]; # synchronous.
} finally {
if {$trusted && \
[lindex [uri softwareupdates] end] eq "trusted"} then {
#
# NOTE: Stop trusting ONLY our own self-signed SSL certificate.
#
uri softwareupdates false
}
}
}
proc getUpdateScriptData { uri } {
#
# NOTE: Start trusting ONLY our own self-signed SSL certificate.
#
set trusted true
if {[lindex [uri softwareupdates] end] eq "untrusted"} then {
uri softwareupdates true
} else {
set trusted false; # NOTE: Already trusted.
}
try {
#
# NOTE: Download the script file from the web site.
#
return [interp readorgetscriptfile $uri]; # synchronous.
} finally {
if {$trusted && \
[lindex [uri softwareupdates] end] eq "trusted"} then {
#
# NOTE: Stop trusting ONLY our own self-signed SSL certificate.
#
uri softwareupdates false
}
}
}
#
# NOTE: This proc is used to check for new versions -OR- new update
# scripts for the runtime when a user executes the interactive
# "#check" command. To disable this functionality, simply
# redefine this procedure to do nothing.
#
proc checkForUpdate {
{wantScripts false} {quiet false} {prompt false}
{automatic false} } {
#
# NOTE: This should work properly in Eagle only.
#
set updateUri [appendArgs \
[info engine UpdateBaseUri] [info engine UpdatePathAndQuery]]
#
# NOTE: Fetch the master update data from the distribution site
# and normalize to Unix-style line-endings.
#
set updateData [string map [list \r\n \n] [getUpdateData $updateUri]]
#
# NOTE: Split the data into lines.
#
set lines [split $updateData \n]
#
# NOTE: Keep track of how many update scripts are processed.
#
array set scriptCount {
invalid 0 fail 0 bad 0
ok 0 error 0
}
#
# NOTE: Check each line to find the build information...
#
foreach line $lines {
#
# NOTE: Remove excess whitespace.
#
set line [string trim $line]
#
# NOTE: Skip blank lines.
#
if {[string length $line] > 0} then {
#
# NOTE: Skip comment lines.
#
if {[string index $line 0] ne "#" && \
[string index $line 0] ne ";"} then {
#
# NOTE: Split the tab-delimited line into fields. The format
# of all lines in the data must be as follows:
#
# <startLine> protocolId <tab> publicKeyToken <tab> name
# <tab> culture <tab> patchLevel <tab> timeStamp <tab>
# baseUri <tab> md5Hash <tab> sha1Hash <tab> sha512Hash
# <tab> notes <newLine>
#
set fields [split $line \t]
#
# NOTE: Grab the protocol Id field.
#
set protocolId [lindex $fields 0]
#
# NOTE: Grab the public key token field.
#
set publicKeyToken [lindex $fields 1]
#
# NOTE: Grab the name field.
#
set name [lindex $fields 2]
#
# NOTE: Grab the culture field.
#
set culture [lindex $fields 3]
#
# NOTE: Figure out which protocol is in use for this line.
# The value "1" means this line specifies a build of
# the script engine. The value "2" means this line
# specifies an update script (via a URI) to evaluate.
# All other values are currently reserved and ignored.
#
set checkBuild [expr {!$wantScripts && $protocolId eq "1"}]
set checkScript [expr {$wantScripts && $protocolId eq "2"}]
#
# NOTE: We only want to find the first line that matches our
# engine. The public key token is being used here to
# make sure we get the same "flavor" of the engine.
# The lines are organized so that the "latest stable
# version" is on the first line (for a given public key
# token), followed by development builds, experimental
# builds, etc.
#
if {($checkBuild || $checkScript) && \
[matchEnginePublicKeyToken $publicKeyToken] && \
[matchEngineName $name] && \
[matchEngineCulture $culture]} then {
#
# NOTE: Grab the patch level field.
#
set patchLevel [lindex $fields 4]
if {[string length $patchLevel] == 0} then {
set patchLevel 0.0.0.0; # no patch level?
}
#
# NOTE: Grab the time-stamp field.
#
set timeStamp [lindex $fields 5]
if {[string length $timeStamp] == 0} then {
set timeStamp 0; #never?
}
#
# NOTE: Does it look like the number of seconds since the epoch
# or some kind of date/time string?
#
if {[string is integer -strict $timeStamp]} then {
set dateTime [clock format $timeStamp]
} else {
set dateTime [clock format [clock scan $timeStamp]]
}
#
# NOTE: Grab the patch level for the running engine.
#
set enginePatchLevel [info engine PatchLevel]
#
# NOTE: Grab the time-stamp for the running engine.
#
set engineTimeStamp [info engine TimeStamp]
if {[string length $engineTimeStamp] == 0} then {
set engineTimeStamp 0; #never?
}
#
# NOTE: Does it look like the number of seconds since the epoch
# or some kind of date/time string?
#
if {[string is integer -strict $engineTimeStamp]} then {
set engineDateTime [clock format $engineTimeStamp]
} else {
set engineDateTime [clock format [clock scan $engineTimeStamp]]
}
#
# NOTE: For build lines, compare the patch level from the line
# to the one we are currently using using a simple patch
# level comparison.
#
if {$checkBuild} then {
set compare [package vcompare $patchLevel $enginePatchLevel]
} else {
#
# NOTE: This is not a build line, no match.
#
set compare -1
}
#
# NOTE: For script lines, use regular expression matching.
#
if {$checkScript} then {
#
# NOTE: Use [catch] here to prevent raising a script error
# due to a malformed patch level regular expression.
#
if {[catch {
regexp -nocase -- $patchLevel $enginePatchLevel
} match]} then {
#
# NOTE: The patch level from the script line was most
# likely not a valid regular expression.
#
set match false
}
} else {
#
# NOTE: This is not a script line, no match.
#
set match false
}
#
# NOTE: Are we interested in further processing this line?
#
if {($checkBuild && $compare > 0) ||
($checkScript && $match)} then {
#
# NOTE: Grab the base URI field (i.e. it may be a mirror
# site).
#
set baseUri [lindex $fields 6]
if {$checkBuild && [string length $baseUri] == 0} then {
set baseUri [info engine Uri]; # primary site.
}
#
# NOTE: Grab the notes field (which may be empty).
#
set notes [lindex $fields 10]
if {[string length $notes] > 0} then {
set notes [unescapeUpdateNotes $notes]
}
#
# NOTE: The engine patch level from the line is greater,
# we are out-of-date. Return the result of our
# checking now.
#
if {$checkBuild} then {
#
# NOTE: Are we supposed to prompt the interactive user,
# if any, to upgrade now?
#
set text [appendArgs \
"latest build " $patchLevel ", dated " $dateTime \
", is newer than the running build " $enginePatchLevel \
", dated " $engineDateTime]
if {$prompt && [isInteractive]} then {
set caption [appendArgs \
[info engine Name] " " [lindex [info level 0] 0]]
if {[object invoke -flags +NonPublic \
Eagle._Components.Private.WindowOps YesOrNo \
[appendArgs $text \n\n "Run the updater now?"] \
$caption false]} then {
#
# NOTE: Ok, run the updater now and then exit.
#
runUpdateAndExit $automatic
}
}
return [list $text [list $baseUri $patchLevel] [list $notes]]
}
#
# NOTE: The script patch level from the line matches the
# current engine patch level exactly, this script
# should be evaluated if it can be authenticated.
#
if {$checkScript} then {
#
# NOTE: First, set the default channel for update script
# status messages. If the test channel has been
# set (i.e. by the test suite), it will be used
# instead.
#
if {![info exists channel]} then {
set channel [expr {[info exists ::test_channel] ? \
$::test_channel : "stdout"}]
}
#
# NOTE: Next, verify the script has a valid base URI.
# For update scripts, this must be the location
# where the update script data can be downloaded.
#
if {[string length $baseUri] == 0} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- invalid baseUri value for update script " \
"line: " $line \"\n]
}
incr scriptCount(invalid); continue
}
#
# NOTE: Next, grab the md5 field and see if it looks valid.
# Below, the value of this field will be compared to
# that of the actual MD5 hash of the downloaded script
# data.
#
set lineMd5 [lindex $fields 7]
if {[string length $lineMd5] == 0} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- invalid md5 value for update script " \
"line: " $line \"\n]
}
incr scriptCount(invalid); continue
}
#
# NOTE: Next, grab the sha1 field and see if it looks valid.
# Below, the value of this field will be compared to
# that of the actual SHA1 hash of the downloaded script
# data.
#
set lineSha1 [lindex $fields 8]
if {[string length $lineSha1] == 0} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- invalid sha1 value for update script " \
"line: " $line \"\n]
}
incr scriptCount(invalid); continue
}
#
# NOTE: Next, grab the sha512 field and see if it looks
# valid. Below, the value of this field will be
# compared to that of the actual SHA512 hash of the
# downloaded script data.
#
set lineSha512 [lindex $fields 9]
if {[string length $lineSha512] == 0} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- invalid sha512 value for update script " \
"line: " $line \"\n]
}
incr scriptCount(invalid); continue
}
#
# NOTE: Next, show the extra information associated with
# this update script, if any.
#
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- fetching update script from \"" $baseUri \
"\" (" $dateTime ") with notes:\n"]
set trimNotes [string trim $notes]
tqputs $channel [appendArgs \
[expr {[string length $trimNotes] > 0 ? $trimNotes : \
"<none>"}] "\n---- end of update script notes\n"]
}
#
# NOTE: Next, attempt to fetch the update script data.
#
set code [catch {getUpdateScriptData $baseUri} result]
if {$code == 0} then {
#
# NOTE: Success, set the script data from the result.
#
set scriptData $result
} else {
#
# NOTE: Failure, report the error message to the log.
#
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- failed to fetch update script: " $result \n]
}
incr scriptCount(fail); continue
}
#
# NOTE: Next, verify that the md5, sha1, and sha512
# hashes of the raw script data match what was
# specified in the md5, sha1, and sha512 fields.
#
set scriptMd5 [hash normal md5 $scriptData]
if {![string equal -nocase $lineMd5 $scriptMd5]} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- wrong md5 value \"" $scriptMd5 \
"\" for update script line: " $line \"\n]
}
incr scriptCount(bad); continue
}
set scriptSha1 [hash normal sha1 $scriptData]
if {![string equal -nocase $lineSha1 $scriptSha1]} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- wrong sha1 value \"" $scriptSha1 \
"\" for update script line: " $line \"\n]
}
incr scriptCount(bad); continue
}
set scriptSha512 [hash normal sha512 $scriptData]
if {![string equal -nocase $lineSha512 $scriptSha512]} then {
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- wrong sha512 value \"" $scriptSha512 \
"\" for update script line: " $line \"\n]
}
incr scriptCount(bad); continue
}
#
# NOTE: Finally, everything looks good. Therefore, just
# evaluate the update script and print the result.
#
if {!$quiet} then {
tqputs $channel [appendArgs \
"---- evaluating update script from \"" $baseUri \
\"...\n]
}
#
# NOTE: Reset the variables that will be used to contain
# the result of the update script.
#
set code 0; set result ""
#
# NOTE: Manually override file name to be returned by
# [info script] to refer back to the originally
# read script base URI.
#
object invoke -flags +NonPublic Interpreter.GetActive \
PushScriptLocation $baseUri true
try {
#
# NOTE: Evaluate the update script in the context of
# the caller.
#
set code [catch {uplevel 1 $scriptData} result]
} finally {
#
# NOTE: Reset manual override of the script file name
# to be returned by [info script].
#
object invoke -flags +NonPublic Interpreter.GetActive \
PopScriptLocation true
}
#
# NOTE: Keep track of the number of update scripts that
# generate Ok and Error return codes.
#
if {$code == 0} then {
incr scriptCount(ok)
} else {
incr scriptCount(error)
}
if {!$quiet} then {
host result $code $result
tqputs $channel "\n---- end of update script results\n"
}
}
} elseif {$checkBuild && $compare < 0} then {
#
# NOTE: The patch level from the line is less, we are more
# up-to-date than the latest version?
#
return [list [appendArgs \
"running build " $enginePatchLevel ", dated " \
$engineDateTime ", is newer than the latest build " \
$patchLevel ", dated " $dateTime]]
} elseif {$checkBuild} then {
#
# NOTE: The patch levels are equal, we are up-to-date.
#
return [list [appendArgs \
"running build " $enginePatchLevel ", dated " \
$engineDateTime ", is the latest build"]]
}
}
}
}
}
#
# NOTE: Figure out what the final result should be. If we get
# to this point when checking for a new build, something
# must have gone awry. Otherwise, report the number of
# update scripts that were successfully processed.
#
if {$wantScripts} then {
set scriptCount(total) [expr [join [array values scriptCount] +]]
if {$scriptCount(total) > 0} then {
return [list [appendArgs \
"processed " $scriptCount(total) " update scripts: " \
[array get scriptCount]]]
} else {
return [list "no update scripts were processed"]
}
} else {
return [list \
"could not determine if running build is the latest build"]
}
}
proc getReturnType { object member } {
if {[string length $object] == 0 || [string length $member] == 0} then {
return ""
}
set code [catch {
object foreach -alias memberInfo \
[object invoke -noinvoke $object $member] {
#
# NOTE: Use the member type to determine which property contains
# the type information we want to return.
#
switch -exact -- [$memberInfo MemberType] {
Field {
return [$memberInfo FieldType.AssemblyQualifiedName]
}
Method {
return [$memberInfo ReturnType.AssemblyQualifiedName]
}
Property {
return [$memberInfo PropertyType.AssemblyQualifiedName]
}
default {
return ""
}
}
}
} result]
#
# NOTE: If no error was raised above, return the result; otherwise,
# return an empty string to indicate a general failure.
#
return [expr {$code == 2 ? $result : ""}]
}
proc getDefaultValue { typeName } {
if {[string length $typeName] == 0} then {
return ""
}
set type [object invoke -create -alias Type GetType $typeName]
if {[string length $type] == 0} then {
return ""
}
return [expr {[$type IsValueType] ? 0 : "null"}]
}
proc getHostSize {} {
#
# NOTE: Attempt to query the size from the host; failing that,
# return a reasonable default value.
#
if {[catch {host size} result] == 0} then {
return $result
}
return [list 80 25]; # TODO: Good default?
}
proc parray { a args } {
if {[llength $args] > 2} then {
error "wrong # args: should be \"parray a ?pattern?\""
}
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
set names [lsort [eval array names array $args]]
set maxLength 0
foreach name $names {
set length [string length $name]
if {$length > $maxLength} {
set maxLength $length
}
}
set stringMap [list \b " " \t " " \r \xB6 \n \xB6]
set maxLength [expr {$maxLength + [string length $a] + 2}]
set hostLength [lindex [getHostSize] 0]
set valueLength [expr {$hostLength - $maxLength - 5}]; # " ... "
foreach name $names {
#
# NOTE: Format the array element name for display.
#
set nameString [string map $stringMap [appendArgs $a ( $name )]]
#
# NOTE: If the value by itself is too long to fit on one host line,
# just truncate and ellipsis it.
#
set valueString [string map $stringMap $array($name)]
if {[string length $valueString] > $valueLength} then {
set valueString [appendArgs [string range $valueString 0 \
[expr {$valueLength - 4}]] " ..."]
}
#
# HACK: Mono does not currently support calling the String.Format
# overload that takes a variable number of arguments via
# reflection (Mono bug #636939).
#
if {![isMono]} then {
set line [string format -verbatim -- [appendArgs "\{0,-" \
$maxLength "\} = {1}"] $nameString $valueString]
} else {
set line [object invoke String Format [appendArgs "\{0,-" \
$maxLength "\} = {1}"] $nameString $valueString]
}
puts stdout $line
}
}
proc pdict { d } {
set maxLength 0
foreach {name value} $d {
set length [string length $name]
if {$length > $maxLength} {
set maxLength $length
}
}
set hostLength [lindex [getHostSize] 0]
set valueLength [expr {$hostLength - $maxLength - 5}]; # " ... "
foreach {name value} $d {
#
# NOTE: If the value by itself is too long to fit on one host line,
# just truncate and ellipsis it.
#
set valueString $value
if {[string length $valueString] > $valueLength} then {
set valueString [appendArgs [string range $valueString 0 \
[expr {$valueLength - 4}]] " ..."]
}
#
# HACK: Mono does not currently support calling the String.Format
# overload that takes a variable number of arguments via
# reflection (Mono bug #636939).
#
if {![isMono]} then {
set line [string format -verbatim -- "{0,-$maxLength} = {1}" \
$name $valueString]
} else {
set line [object invoke String Format "{0,-$maxLength} = {1}" \
$name $valueString]
}
puts stdout $line
}
}
proc test { name description args } {
#
# NOTE: Determine if the caller is trying to run an old style or
# new style test and use the appropriate command.
#
if {[string index [lindex $args 0] 0] eq "-"} then {
#
# NOTE: New style test, use [test2] command.
#
set command test2
} else {
#
# NOTE: Old style test, use [test1] command.
#
set command test1
}
return [uplevel 1 [list $command $name $description] $args]
}
proc unknown { name args } {
#
# NOTE: This is a stub unknown procedure that simply produces an
# appropriate error message.
#
# TODO: Add support for auto-loading packages here in the future?
#
return -code error "invalid command name \"$name\""
}
namespace eval ::tcl::tm {
#
# NOTE: Ideally, this procedure should be created in the "::tcl::tm"
# namespace.
#
proc ::tcl::tm::UnknownHandler { original name args } {
#
# NOTE: Do nothing except call the original handler.
#
uplevel 1 $original [::linsert $args 0 $name]
}
}
proc tclPkgUnknown { name args } {
#
# NOTE: Force a rescan of "pkgIndex" files. This must be done in
# the global scope so that the special global variable 'dir'
# set by the package index loading subsystem can be accessed.
#
uplevel #0 [list package scan -host -normal -refresh]
}
proc tclLog { string } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
catch {puts stderr $string}
}
proc makeVariableFast { name fast } {
#
# NOTE: This should work properly in Eagle only.
#
catch {
uplevel 1 [list object invoke -flags +NonPublic \
Interpreter.GetActive MakeVariableFast $name $fast]
}
}
proc findDirectories { pattern } {
#
# NOTE: Block non-Windows platforms since this is Windows specific.
#
if {![isWindows]} then {
error "not supported on this operating system"
}
#
# NOTE: This should work properly in Eagle only.
#
set dir ""; set result [list]
#
# HACK: Optimize the variable access in this procedure to be
# as fast as possible.
#
makeVariableFast dir true; makeVariableFast result true
foreach dir [split [exec -unicode $::env(ComSpec) /u /c dir \
/ad /b [appendArgs \" [file nativename $pattern] \"]] \n] {
set dir [string trim $dir]
if {[string length $dir] > 0} then {
set dir [getDirResultPath $pattern $dir]
if {[lsearch -variable -exact -nocase result $dir] == -1} then {
lappend result $dir
}
}
}
foreach dir [split [exec -unicode $::env(ComSpec) /u /c dir \
/ahd /b [appendArgs \" [file nativename $pattern] \"]] \n] {
set dir [string trim $dir]
if {[string length $dir] > 0} then {
set dir [getDirResultPath $pattern $dir]
if {[lsearch -variable -exact -nocase result $dir] == -1} then {
lappend result $dir
}
}
}
return $result
}
proc findFiles { pattern } {
#
# NOTE: Block non-Windows platforms since this is Windows specific.
#
if {![isWindows]} then {
error "not supported on this operating system"
}
#
# NOTE: This should work properly in Eagle only.
#
set fileName ""; set result [list]
#
# HACK: Optimize the variable access in this procedure to be
# as fast as possible.
#
makeVariableFast fileName true; makeVariableFast result true
foreach fileName [split [exec -unicode $::env(ComSpec) /u /c dir \
/a-d /b [appendArgs \" [file nativename $pattern] \"]] \n] {
set fileName [string trim $fileName]
if {[string length $fileName] > 0} then {
set fileName [getDirResultPath $pattern $fileName]
if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
lappend result $fileName
}
}
}
foreach fileName [split [exec -unicode $::env(ComSpec) /u /c dir \
/ah-d /b [appendArgs \" [file nativename $pattern] \"]] \n] {
set fileName [string trim $fileName]
if {[string length $fileName] > 0} then {
set fileName [getDirResultPath $pattern $fileName]
if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
lappend result $fileName
}
}
}
return $result
}
proc findFilesRecursive { pattern } {
#
# NOTE: Block non-Windows platforms since this is Windows specific.
#
if {![isWindows]} then {
error "not supported on this operating system"
}
#
# NOTE: This should work properly in Eagle only.
#
set fileName ""; set result [list]
#
# HACK: Optimize the variable access in this procedure to be
# as fast as possible.
#
makeVariableFast fileName true; makeVariableFast result true
foreach fileName [split [exec -unicode $::env(ComSpec) /u /c dir \
/a-d /s /b [appendArgs \" [file nativename $pattern] \"]] \n] {
set fileName [string trim $fileName]
if {[string length $fileName] > 0} then {
set fileName [getDirResultPath $pattern $fileName]
if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
lappend result $fileName
}
}
}
foreach fileName [split [exec -unicode $::env(ComSpec) /u /c dir \
/ah-d /s /b [appendArgs \" [file nativename $pattern] \"]] \n] {
set fileName [string trim $fileName]
if {[string length $fileName] > 0} then {
set fileName [getDirResultPath $pattern $fileName]
if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
lappend result $fileName
}
}
}
return $result
}
proc loadWordTcl { directory } {
uplevel 1 [list source [file join $directory word.tcl]]
}
#
# NOTE: Add script library files borrowed from native Tcl.
#
if {![interp issafe]} then {
loadWordTcl [file dirname [info script]]
}
###########################################################################
############################# END Eagle ONLY ##############################
###########################################################################
} else {
###########################################################################
############################# BEGIN Tcl ONLY ##############################
###########################################################################
proc getLengthModifier { value } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
return [expr {int($value) != wide($value) ? "l" : ""}]
}
proc debug { args } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
puts stdout [lrange $args 2 end]
}
proc findDirectories { pattern } {
#
# NOTE: This should work properly in Tcl only.
#
eval lappend result [glob -nocomplain -types {d} \
[file normalize $pattern]]
eval lappend result [glob -nocomplain -types {d hidden} \
[file normalize $pattern]]
return $result
}
proc findFiles { pattern } {
#
# NOTE: This should work properly in Tcl only.
#
eval lappend result [glob -nocomplain -types {f} \
[file normalize $pattern]]
eval lappend result [glob -nocomplain -types {f hidden} \
[file normalize $pattern]]
return $result
}
proc findFilesRecursive { pattern } {
#
# NOTE: Block non-Windows platforms since this is Windows specific.
#
if {![isWindows]} then {
error "not supported on this operating system"
}
#
# NOTE: This should work properly in Tcl only.
#
set result [list]
catch {
foreach fileName [split [exec $::env(ComSpec) /c dir /a-d /s /b \
[file nativename $pattern]] \n] {
set fileName [string trim $fileName]
if {[string length $fileName] > 0} then {
set fileName [getDirResultPath $pattern $fileName]
if {[lsearch -exact -nocase $result $fileName] == -1} then {
lappend result $fileName
}
}
}
}
catch {
foreach fileName [split [exec $::env(ComSpec) /c dir /ah-d /s /b \
[file nativename $pattern]] \n] {
set fileName [string trim $fileName]
if {[string length $fileName] > 0} then {
set fileName [getDirResultPath $pattern $fileName]
if {[lsearch -exact -nocase $result $fileName] == -1} then {
lappend result $fileName
}
}
}
}
return $result
}
proc exportAndImportPackageCommands { namespace exports forget force } {
#
# NOTE: This should work properly in Tcl only.
#
# NOTE: Forget any previous commands that were imported from this
# namespace into the global namespace?
#
if {$forget} then {
namespace eval :: [list namespace forget [appendArgs $namespace ::*]]
}
#
# NOTE: Process each command to be exported from the specified
# namespace and import it into the global namespace, if
# necessary.
#
foreach export $exports {
#
# NOTE: Force importing of our exported commands into the global
# namespace? Otherwise, see if the command is already
# present in the global namespace before trying to import
# it.
#
if {$force || \
[llength [info commands [appendArgs :: $export]]] == 0} then {
#
# NOTE: Export the specified command from the specified namespace.
#
namespace eval $namespace [list namespace export $export]
#
# NOTE: Import the specified command into the global namespace.
#
set namespaceExport [appendArgs $namespace :: $export]
if {$force} then {
namespace eval :: [list namespace import -force $namespaceExport]
} else {
namespace eval :: [list namespace import $namespaceExport]
}
}
}
}
#
# NOTE: Exports the necessary commands from this package and import them
# into the global namespace.
#
exportAndImportPackageCommands [namespace current] [list \
isEagle isWindows isInteractive haveGaruda isTclThread isMono \
isSameFileName getEnvironmentVariable combineFlags getCompileInfo \
getPlatformInfo getPluginPath appendArgs lappendArgs \
getDictionaryValue getColumnValue getRowColumnValue tqputs tqlog \
readFile readSharedFile writeFile appendFile appendLogFile \
appendSharedFile appendSharedLogFile readAsciiFile writeAsciiFile \
readUnicodeFile writeUnicodeFile getDirResultPath addToPath \
removeFromPath execShell lshuffle ldifference filter map reduce \
getLengthModifier debug findDirectories findFiles findFilesRecursive \
exportAndImportPackageCommands] false false
###########################################################################
############################## END Tcl ONLY ###############################
###########################################################################
}
#
# NOTE: Provide the Eagle library package to the interpreter.
#
package provide Eagle.Library \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}