###############################################################################
#
# tdk.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# TclDevKit Debugger Integration Package
#
# 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 {
if {[isEagle]} then {
#
# NOTE: This procedure attempts to locate an installed instance of the
# "modern" ActiveState TclDevKit (e.g. version 5.4.0). If found,
# the directory it was installed into will be returned; otherwise,
# an empty string will be returned.
#
proc getTclDevKitDirectory {} {
try {
set keyName Software\\ActiveState\\TclDevKit
set fullKeyName [appendArgs HKEY_LOCAL_MACHINE\\ $keyName]
set version [object invoke Microsoft.Win32.Registry GetValue \
$fullKeyName CurrentVersion null]
if {[string length $version] > 0} then {
set directory [object invoke Microsoft.Win32.Registry GetValue \
[appendArgs $fullKeyName \\ $version] null null]
if {[string length $version] > 0} then {
return $directory
}
}
set subKey [object invoke -alias \
Microsoft.Win32.Registry.LocalMachine OpenSubKey $keyName]
if {[string length $subKey] > 0} then {
foreach subKeyName [$subKey GetSubKeyNames] {
try {
set subSubKey [$subKey -alias OpenSubKey $subKeyName]
if {[string length $subSubKey] > 0} then {
set directory [$subSubKey GetValue null]
if {[string length $directory] > 0} then {
return $directory
}
}
} finally {
unset -nocomplain subSubKey
}
}
}
return ""
} finally {
unset -nocomplain subKey
}
}
#
# NOTE: This procedure evaluates the specified Tcl script, either via a
# normal Tcl interpreter on this thread -OR- via an isolated Tcl
# thread.
#
proc tcl_eval { interp args } {
if {[isTclThread $interp]} then {
eval tcl queue -eventflags Immediate -synchronous true \
[list $interp] $args
} else {
eval tcl eval [list $interp] $args
}
}
#
# NOTE: This procedure attempts to load the TclDevKit remote debugger
# package into the specified Tcl interpreter. By default, the
# "primary" Tcl interpreter will be used. If the native Tcl
# interface is not ready or if the remote debugger package
# cannot be loaded, an error will be raised.
#
proc tcl_debugger_setup { {interp ""} } {
if {![tcl ready]} then {error "native Tcl interface is not ready"}
if {[string length $interp] == 0} then {set interp [tcl primary]}
set directory [getTclDevKitDirectory]
if {[string length $directory] == 0} then {
error "the TclDevKit does not appear to be installed"
}
set directory [file join $directory lib tcldebugger_attach]
tcl_eval $interp [list lappend auto_path [file normalize $directory]]
tcl_eval $interp [list package require tcldebugger_attach]
}
#
# NOTE: This procedure attempts to startup the installed TclDevKit
# debugger application and force it to listen on its default
# port (i.e. for use as a remote script debugger). Then, it
# waits a brief period of time before returning (i.e. to allow
# the TclDevKit debugger application to fully startup).
#
proc tcl_debugger_startup {} {
set directory [getTclDevKitDirectory]
if {[string length $directory] == 0} then {
error "the TclDevKit does not appear to be installed"
}
set applicationFileName [file join $directory bin [appendArgs \
tcldebugger [info programextension]]]
if {![file exists $applicationFileName]} then {
error [appendArgs \
"the TclDevKit debugger application file \"" \
$applicationFileName "\" not found"]
}
global tdk_path
if {![info exists tdk_path]} then {
error "the TclDevKit debugger project file path is not set"
}
set projectFileName [file join $tdk_path remote.tpj]
if {![file exists $projectFileName]} then {
error [appendArgs \
"the TclDevKit debugger project file \"" \
$projectFileName "\" not found"]
}
exec $applicationFileName $projectFileName &; after 5000
}
#
# NOTE: This procedure attempts to initialize the TclDevKit remote
# debugger in the specified Tcl interpreter. By default, the
# "primary" Tcl interpreter will be used. If the native Tcl
# interface is not ready or if the remote debugger package
# cannot be initialized, an error will be raised.
#
proc tcl_debugger_init {
{interp ""} {host 127.0.0.1} {port 2576} {cdata {}} } {
if {![tcl ready]} then {error "native Tcl interface is not ready"}
if {[string length $interp] == 0} then {set interp [tcl primary]}
tcl_eval $interp [list debugger_init $host $port $cdata]
}
#
# NOTE: This procedure attempts to evaluate a Tcl script under control
# of the TclDevKit remote debugger. By default, the "primary" Tcl
# interpreter will be used. If the native Tcl interface is not
# ready or if the remote debugger package fails to evaluate the
# Tcl script, an error will be raised.
#
proc tcl_debugger_eval { {interp ""} args } {
if {![tcl ready]} then {error "native Tcl interface is not ready"}
if {[string length $interp] == 0} then {set interp [tcl primary]}
tcl_eval $interp debugger_eval $args
}
#
# NOTE: This procedure attempts to tell the TclDevKit remote debugger
# to break the execution of the Tcl script in progress.
#
proc tcl_debugger_break { {interp ""} {str ""} } {
if {![tcl ready]} then {error "native Tcl interface is not ready"}
if {[string length $interp] == 0} then {set interp [tcl primary]}
tcl_eval $interp [list debugger_break $str]
}
}
if {![info exists tdk_path]} then {
set tdk_path [file dirname [info script]]
}
package provide Eagle.TclDevKit.Integration \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}