############################################################################### # # 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: # # ... # 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: # # protocolId publicKeyToken name # culture patchLevel timeStamp # baseUri md5Hash sha1Hash sha512Hash # notes # 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 : \ ""}] "\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"}] }