├── lib ├── tclparser │ ├── DEPENDENCIES │ ├── doc │ │ ├── parse.pdf │ │ └── parse.man │ ├── README │ ├── aclocal.m4 │ ├── tools │ │ └── check_manifest │ ├── tclconfig │ │ └── README.txt │ ├── tests │ │ ├── all.tcl │ │ └── parseCmd.test │ ├── win │ │ ├── makefile.vc │ │ └── rules-ext.vc │ ├── license.terms │ ├── ChangeLog │ └── configure.in ├── tcldebugger │ ├── pkgIndex.tcl │ ├── images │ │ ├── go.gif │ │ ├── go_d.gif │ │ ├── kill.gif │ │ ├── logo.gif │ │ ├── stop.gif │ │ ├── about.gif │ │ ├── kill_d.gif │ │ ├── stepin.gif │ │ ├── stepto.gif │ │ ├── stop_d.gif │ │ ├── var_d.gif │ │ ├── var_e.gif │ │ ├── break_d.gif │ │ ├── break_e.gif │ │ ├── break_m.gif │ │ ├── current.gif │ │ ├── current_d.gif │ │ ├── current_e.gif │ │ ├── current_m.gif │ │ ├── current_v.gif │ │ ├── history.gif │ │ ├── refresh.gif │ │ ├── refresh_d.gif │ │ ├── restart.gif │ │ ├── restart_d.gif │ │ ├── stepin_d.gif │ │ ├── stepout.gif │ │ ├── stepout_d.gif │ │ ├── stepover.gif │ │ ├── stepto_d.gif │ │ ├── win_break.gif │ │ ├── win_cover.gif │ │ ├── win_eval.gif │ │ ├── win_proc.gif │ │ ├── win_watch.gif │ │ ├── combo_arrow.gif │ │ ├── stepover_d.gif │ │ ├── stepresult.gif │ │ ├── debugUnixIcon.gif │ │ ├── history_enable.gif │ │ ├── history_mixed.gif │ │ ├── stepresult_d.gif │ │ └── history_disable.gif │ ├── tests │ │ ├── pkgIndex.tcl │ │ ├── all.tcl │ │ ├── system.test │ │ ├── startup.tcl │ │ ├── initdebug.test │ │ ├── guiLaunch.tcl │ │ ├── dbgLaunch.tcl │ │ └── block.test │ ├── oratcl.pdx │ ├── sybtcl.pdx │ ├── tclCom.pdx │ ├── tcltest.pdx │ ├── xmlGen.pdx │ ├── uplevel.pdx │ ├── blend.pdx │ ├── result.tcl │ ├── util.tcl │ ├── appLaunch.tcl │ ├── location.tcl │ ├── font.tcl │ ├── image.tcl │ ├── initdebug.tcl │ ├── file.tcl │ ├── portWin.tcl │ ├── varWin.tcl │ ├── break.tcl │ ├── toolbar.tcl │ └── evalWin.tcl ├── projectInfo │ └── pkgIndex.tcl ├── remotedebug │ ├── docs │ │ ├── initdebug.pdf │ │ └── initdebug.n │ ├── pkgIndex.tcl │ └── initdebug.tcl └── cmdline │ └── pkgIndex.tcl ├── bin ├── TclProDebug.kit ├── TclProDebug.linux ├── prodebug └── makestarkit.tcl ├── src ├── images │ ├── about.gif │ ├── logo.gif │ └── debugUnixIcon.gif └── startup.tcl ├── demos ├── tutorials │ ├── remote.tcl │ ├── fac.tcl │ ├── varbreak.tcl │ ├── fac-gui.tcl │ └── pulse.tcl ├── fac │ ├── tour.txt │ └── fac.tcl ├── xpm │ ├── tour.txt │ └── makeXpm.tcl ├── hiq │ ├── hiq.tcl │ ├── tour.txt │ ├── hiqState.tcl │ └── hiqGUI.tcl └── uplevel │ └── uplevel.tcl ├── README.remotedebugging ├── README ├── license.terms ├── main.tcl └── starkit.manifest /lib/tclparser/DEPENDENCIES: -------------------------------------------------------------------------------- 1 | # List each dependent module on a line by itself 2 | tcl 3 | -------------------------------------------------------------------------------- /bin/TclProDebug.kit: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/bin/TclProDebug.kit -------------------------------------------------------------------------------- /bin/TclProDebug.linux: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/bin/TclProDebug.linux -------------------------------------------------------------------------------- /lib/tcldebugger/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | package ifneeded debugger 2.0 [list source [file join $dir debugger.tcl]] -------------------------------------------------------------------------------- /src/images/about.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/src/images/about.gif -------------------------------------------------------------------------------- /src/images/logo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/src/images/logo.gif -------------------------------------------------------------------------------- /lib/projectInfo/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | package ifneeded projectInfo 2.0 [list source [file join $dir projectInfo.tcl]] 2 | -------------------------------------------------------------------------------- /lib/tclparser/doc/parse.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tclparser/doc/parse.pdf -------------------------------------------------------------------------------- /src/images/debugUnixIcon.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/src/images/debugUnixIcon.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/go.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/go.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/go_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/go_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/kill.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/kill.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/logo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/logo.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stop.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stop.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/about.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/about.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/kill_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/kill_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepin.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepin.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepto.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepto.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stop_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stop_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/var_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/var_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/var_e.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/var_e.gif -------------------------------------------------------------------------------- /lib/remotedebug/docs/initdebug.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/remotedebug/docs/initdebug.pdf -------------------------------------------------------------------------------- /lib/tcldebugger/images/break_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/break_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/break_e.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/break_e.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/break_m.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/break_m.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/current.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/current.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/current_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/current_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/current_e.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/current_e.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/current_m.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/current_m.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/current_v.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/current_v.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/history.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/history.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/refresh.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/refresh.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/refresh_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/refresh_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/restart.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/restart.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/restart_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/restart_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepin_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepin_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepout.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepout.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepout_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepout_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepover.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepover.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepto_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepto_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/win_break.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/win_break.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/win_cover.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/win_cover.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/win_eval.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/win_eval.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/win_proc.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/win_proc.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/win_watch.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/win_watch.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/combo_arrow.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/combo_arrow.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepover_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepover_d.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepresult.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepresult.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/debugUnixIcon.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/debugUnixIcon.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/history_enable.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/history_enable.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/history_mixed.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/history_mixed.gif -------------------------------------------------------------------------------- /lib/tcldebugger/images/stepresult_d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/stepresult_d.gif -------------------------------------------------------------------------------- /bin/prodebug: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | source [file dirn [file dirn [file dirn [file norm [file join [info script] __dummy__]]]]]/main.tcl 4 | -------------------------------------------------------------------------------- /demos/tutorials/remote.tcl: -------------------------------------------------------------------------------- 1 | source prodebug.tcl 2 | 3 | debugger_init localhost 2576 4 | debugger_eval { 5 | source pulse.tcl 6 | } 7 | 8 | -------------------------------------------------------------------------------- /lib/tcldebugger/images/history_disable.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/TclProDebug/master/lib/tcldebugger/images/history_disable.gif -------------------------------------------------------------------------------- /lib/remotedebug/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | package ifneeded remotedebug 2.0 "[list source [file join $dir initdebug.tcl]];[::list package provide remotedebug 2.0]" 2 | -------------------------------------------------------------------------------- /lib/cmdline/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | if {![package vsatisfies [package provide Tcl] 8.2]} {return} 2 | package ifneeded cmdline 1.3.3 [list source [file join $dir cmdline.tcl]] 3 | -------------------------------------------------------------------------------- /lib/tclparser/README: -------------------------------------------------------------------------------- 1 | # Copyright (c) 1999-2000 Ajuba Solutions 2 | 3 | This is the Tcl parser component used by the checker to 4 | parse a Tcl script into commands, words and tokens. 5 | 6 | -------------------------------------------------------------------------------- /lib/tclparser/aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /README.remotedebugging: -------------------------------------------------------------------------------- 1 | Remote debugging of programs still works as described in the TclPro User Manual 2 | and the initdebug man page at lib/remotedebug/docs/initdebug.pdf. 3 | 4 | The only addition is that for the sake of convenience the initdebug.tcl file has 5 | been wrapped in a package, so that (assuming the auto_path variable has been 6 | initialized properly) a client code file can be prepared for remote debugging 7 | simply by adding the commands: 8 | 9 | package require remotedebug 10 | debugger_init 11 | debugger_eval {} 12 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | # Tcl package index file, version 1.1 2 | # This file is generated by the "pkg_mkIndex -direct" command 3 | # and sourced either when an application starts up or 4 | # by a "package unknown" script. It invokes the 5 | # "package ifneeded" command to set up package-related 6 | # information so that packages will be loaded automatically 7 | # in response to "package require" commands. When this 8 | # script is sourced, the variable $dir must contain the 9 | # full path name of this file's directory. 10 | 11 | package ifneeded protest 1.0 [list source [file join $dir protest.tcl]] 12 | -------------------------------------------------------------------------------- /lib/tcldebugger/oratcl.pdx: -------------------------------------------------------------------------------- 1 | # oratcl.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for OraTcl. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: oratcl.pdx,v 1.3 2000/05/30 22:54:42 hershey Exp $ 10 | 11 | # Register the Oratcl extension 12 | 13 | instrument::addExtension 2.0 {OraTcl} 14 | 15 | # Register handlers for each of the Oratcl commands 16 | 17 | instrument::addCommand orafetch {parseSimpleArgs 1 -1 {parseWord parseBody parseWord}} 18 | -------------------------------------------------------------------------------- /lib/tcldebugger/sybtcl.pdx: -------------------------------------------------------------------------------- 1 | # sybtcl.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for Sybtcl. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | # Register the Sybtcl extension 11 | 12 | instrument::addExtension 2.0 {sybtcl} 13 | 14 | # Register handlers for each of the Sybtcl commands 15 | 16 | instrument::addCommand sybevent {parseSimpleArgs 1 2 { 17 | parseWord parseBody}} 18 | 19 | instrument::addCommand sybnext {parseSimpleArgs 1 -1 { 20 | parseWord parseBody parseWord}} 21 | -------------------------------------------------------------------------------- /lib/tcldebugger/tclCom.pdx: -------------------------------------------------------------------------------- 1 | # tclCom.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the Tcl 4 | # Com API. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the Tcl Com extension 12 | 13 | instrument::addExtension 2.0 {tclCom} 14 | 15 | # Register handlers for each of the XML Generation commands 16 | 17 | instrument::addCommand foreachitem {parseTail 3 { 18 | parseWord parseBody}} 19 | instrument::addCommand tclcom::foreachitem {parseTail 3 { 20 | parseWord parseBody}} 21 | -------------------------------------------------------------------------------- /lib/tcldebugger/tcltest.pdx: -------------------------------------------------------------------------------- 1 | # tcltest.pdx -- 2 | # 3 | # This file implements custom instrumenter extensions 4 | # for the tcltest package. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the tcltest extension 12 | 13 | instrument::addExtension 2.0 {parseTest} 14 | 15 | namespace eval parseTest { 16 | } 17 | 18 | # Register handlers for each of the tcltest commands 19 | 20 | instrument::addCommand test {parseTail 4 { 21 | parseWord parseBody parseWord}} 22 | instrument::addCommand tcltest::test {parseTail 4 { 23 | parseWord parseBody parseWord}} 24 | -------------------------------------------------------------------------------- /lib/tcldebugger/xmlGen.pdx: -------------------------------------------------------------------------------- 1 | # xmlGen.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the XML 4 | # Generation API. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the XML Generation extension 12 | 13 | instrument::addExtension 2.0 {xmlGen} 14 | 15 | # Register handlers for each of the XML Generation commands 16 | 17 | instrument::addCommand element {parseSimpleArgs 2 4 { 18 | parseWord parseWord parseWord parseBody}} 19 | instrument::addCommand xmlgen::element {parseSimpleArgs 2 4 { 20 | parseWord parseWord parseWord parseBody}} 21 | -------------------------------------------------------------------------------- /bin/makestarkit.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | set startDir [pwd] 4 | 5 | try { 6 | set binDir [file dir [file norm [file join [info script] .. __dummy__]]] 7 | cd $binDir 8 | set appDir [file root [file tail [file dir $binDir]]] 9 | file delete -force ./$appDir.vfs 10 | file mkdir ./$appDir.vfs 11 | set f [open ../starkit.manifest] 12 | foreach sfile [read $f] { 13 | file mkdir [file join $appDir.vfs [file dir $sfile]] 14 | file copy ../$sfile [file join $appDir.vfs $sfile] 15 | } 16 | lassign [concat [lindex $argv 0] sdx.kit] sdx 17 | if {![file isfile $sdx]} { 18 | error "please specify pathname of sdx.kit on command line." 19 | } 20 | exec [info nameofexecutable] $sdx wrap $appDir.kit 21 | } finally { 22 | close $f 23 | cd $startDir 24 | } -------------------------------------------------------------------------------- /demos/fac/tour.txt: -------------------------------------------------------------------------------- 1 | tour.txt -- 2 | 3 | This file contains a sequence of actions to take to give an 4 | alpha demo. 5 | 6 | Copyright (c) 1998 Scriptics Corporation 7 | All rights reserved. 8 | 9 | RCS: @(#) $Id: tour.txt,v 1.1 2000/07/14 18:00:02 welch Exp $ 10 | 11 | 1) load demos/fac/fac.tcl with tclsh and cmdline args: 4 5 12 | 13 | notice the values of argc and argv 14 | 15 | 2) open watch window 16 | 17 | add x, temp, y, and fact to watch window 18 | 19 | 3) start stepping 20 | 21 | step into first fact call 22 | 23 | keep stepping through 24 | 25 | step-out at deepest return 26 | 27 | 28 | 5) add var-bpts for y 29 | 30 | 6) step "over" the 2nd call to fact 31 | 32 | keep pressing run util at deepest return 33 | 34 | step out 35 | -------------------------------------------------------------------------------- /lib/tclparser/tools/check_manifest: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/tclsh 2 | # -*- tcl -*- 3 | # check the manifest against the current contents of the directory 4 | 5 | set manifest [lindex $argv 0] 6 | 7 | rename file ori_file 8 | proc file {name} { 9 | global files 10 | set files($name) 1 11 | if {! [ori_file exists $name]} { 12 | puts stdout "missing: $name" 13 | } 14 | } 15 | 16 | # read manifest and check existence of all listed files 17 | source $manifest 18 | 19 | 20 | # now backwards: find all files and check 21 | # for files not listed in the manifest 22 | 23 | set list [exec find . -print] 24 | regsub -all "\n" $list { } list 25 | 26 | foreach f $list { 27 | if {[catch {set files($f)}]} { 28 | puts stdout "new: $f" 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /lib/tclparser/tclconfig/README.txt: -------------------------------------------------------------------------------- 1 | These files comprise the basic building blocks for a Tcl Extension 2 | Architecture (TEA) extension. For more information on TEA see: 3 | 4 | http://www.tcl.tk/doc/tea/ 5 | 6 | This package is part of the Tcl project at SourceForge, and latest 7 | sources should be available there: 8 | 9 | http://tcl.sourceforge.net/ 10 | 11 | This package is a freely available open source package. You can do 12 | virtually anything you like with it, such as modifying it, redistributing 13 | it, and selling it either in whole or in part. 14 | 15 | CONTENTS 16 | ======== 17 | The following is a short description of the files you will find in 18 | the sample extension. 19 | 20 | README.txt This file 21 | 22 | install-sh Program used for copying binaries and script files 23 | to their install locations. 24 | 25 | tcl.m4 Collection of Tcl autoconf macros. Included by a package's 26 | aclocal.m4 to define TEA_* macros. 27 | -------------------------------------------------------------------------------- /demos/xpm/tour.txt: -------------------------------------------------------------------------------- 1 | tour.txt -- 2 | 3 | This file contains a sequence of actions to take to give an 4 | alpha demo. 5 | 6 | Copyright (c) 1998 Scriptics Corporation 7 | All rights reserved. 8 | 9 | RCS: @(#) $Id: tour.txt,v 1.1 2000/07/14 18:00:24 welch Exp $ 10 | 11 | 1) load makeXPM.tcl with tclsh and cmdline args: 6 8 4 design.xpm 12 | 13 | 2) open proc window and start stepping 14 | 15 | add breakpoints at beginning of red and indigo 16 | 17 | 3) step in "writeToFile" 18 | 19 | run 20 | 21 | 4) step-in until "result" has a value 22 | 23 | watch "color" 24 | 25 | inspect "result"--live 26 | 27 | run 28 | 29 | 5) stopped in indigo 30 | 31 | ..... 32 | 33 | step-out repeatedly 34 | 35 | 5) goto writeToFile stack level 36 | 37 | inspect "repeatNumber"--live 38 | 39 | inspect "lineNumber"--live+bpt 40 | 41 | remove all bpts 42 | 43 | run 44 | 45 | 6) interrupt 46 | 47 | run 48 | 49 | interrupt 50 | 51 | run 52 | -------------------------------------------------------------------------------- /demos/tutorials/fac.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # the next line restarts using protclsh82 \ 3 | exec protclsh82 "$0" "$@" 4 | 5 | # fac.tcl -- 6 | # 7 | # This program computes factorials. It is intended as a 8 | # simple demo application for TclPro. 9 | 10 | # This procedure computes the factorial of its argument using a 11 | # recursive approach and returns the factorial as a result. 12 | 13 | proc fac x { 14 | if {$x <= 1} { 15 | return 1 16 | } 17 | set next [expr {$x - 1}] 18 | return [expr {$x * [fac $next]}] 19 | } 20 | 21 | set iter 1 22 | 23 | while {$iter == 1} { 24 | 25 | # Prompt for a value 26 | 27 | puts -nonewline "Enter a number: " 28 | flush stdout 29 | set value [gets stdin] 30 | 31 | # Output the factorial 32 | 33 | puts "${value}! is [fac $value]" 34 | 35 | # Do it again? 36 | 37 | puts -nonewline "Calculate another factorial? (y/n) " 38 | flush stdout 39 | set iter [regexp {^[yY]} [gets stdin]] 40 | } 41 | -------------------------------------------------------------------------------- /demos/tutorials/varbreak.tcl: -------------------------------------------------------------------------------- 1 | # varbreak.tcl -- 2 | # 3 | # This program increments a variable "x". It was designed to 4 | # illustrate variable breakpoints in TclPro Debugger. 5 | # 6 | # Copyright (c) 1999 Scriptics Corporation 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | set x 0 11 | 12 | label .x -textvariable x 13 | pack .x -padx 6 -pady 4 14 | button .incr -text "Increment" -command {Increment x} 15 | pack .incr -side left -expand yes -padx 4 -pady 4 16 | button .decr -text "Decrement" -command {Decrement x} 17 | pack .decr -side left -expand yes -padx 4 -pady 4 18 | 19 | # 20 | # Increment - Increases the value of the variable whose name is 21 | # "varName" by one. 22 | # 23 | 24 | proc Increment {varName} { 25 | global $varName 26 | incr $varName 27 | } 28 | 29 | # 30 | # Decrement - Reduces the value of the variable "varName" by one. 31 | # 32 | 33 | proc Decrement {varName} { 34 | global $varName 35 | incr $varName -1 36 | } 37 | 38 | -------------------------------------------------------------------------------- /demos/tutorials/fac-gui.tcl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # the next line restarts using prowish82 \ 3 | exec prowish82 "$0" "$@" 4 | 5 | # fac.tcl -- 6 | # 7 | # This program creates a simple Tk graphical user interface to 8 | # compute factorials. It is intended as a demo application for 9 | # TclPro. 10 | 11 | # This procedure computes the factorial of its argument using a 12 | # recursive approach and returns the factorial as result. 13 | 14 | proc fac x { 15 | if {$x <= 1} { 16 | return 1 17 | } 18 | set next [expr {$x - 1}] 19 | return [expr {$x * [fac $next]}] 20 | } 21 | 22 | # Create the three widgets that make up the GUI for the application 23 | # and arrange them in a gridded pattern. 24 | 25 | label .label1 -text "Enter number:" 26 | entry .entry 27 | label .label2 -textvariable answer 28 | grid .label1 .entry 29 | grid .label2 -columnspan 2 30 | 31 | # Arrange for the fac procedure to be invoked whenever Return is typed 32 | # in the entry widget. The result is stored in variable "answer"; the 33 | # widget .label2 always displays the value of this variable. 34 | 35 | bind .entry { 36 | set answer "Answer is [fac [.entry get]]" 37 | } 38 | -------------------------------------------------------------------------------- /demos/hiq/hiq.tcl: -------------------------------------------------------------------------------- 1 | # hiq.tcl -- 2 | # 3 | # Main code for the Hi-Q game. This file initializes the global variables 4 | # and sources other code files. 5 | # 6 | # Copyright (c) 1996 Dartmouth College 7 | # Copyright (c) 1998 Scriptics Corporation 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | # RCS: @(#) $Id: hiq.tcl,v 1.2 2000/10/31 23:31:09 welch Exp $ 11 | 12 | 13 | # "color" is an associative array which we use to abstract away the font 14 | # and color attributes of all tk widgets. 15 | 16 | set color(bg) white 17 | set color(fg) black 18 | set color(button-bg) steelblue 19 | set color(button-mute) lightsteelblue 20 | set color(button-fg) white 21 | set color(canvas-bg) white 22 | set color(canvas-fg) steelblue 23 | set color(peg) pink 24 | set color(hole) black 25 | set color(fontsize) 24 26 | set color(font) -*-helvetica-medium-r-*-*-24-*-*-*-*-*-*-* 27 | #set color(fontsize) 14 28 | #set color(font) -adobe-courier-medium-r-*-*-14-*-*-*-*-*-*-* 29 | 30 | # source the other files... 31 | 32 | source hiqGUI.tcl 33 | source hiqState.tcl 34 | 35 | # pop up the main window & start the game 36 | 37 | set board_obj [pop_up_main_window] 38 | start_game $board_obj 39 | -------------------------------------------------------------------------------- /demos/hiq/tour.txt: -------------------------------------------------------------------------------- 1 | tour.txt -- 2 | 3 | This file contains a sequence of actions to take to give an 4 | alpha demo. 5 | 6 | Copyright (c) 1998 Scriptics Corporation 7 | All rights reserved. 8 | 9 | RCS: @(#) $Id: tour.txt,v 1.1 2000/07/14 18:00:03 welch Exp $ 10 | 11 | 1) open demos/hiq/hiqGUI.tcl 12 | 13 | 2) add breakpoint on "pack .hiq", line 49 14 | 15 | open breakpoint window 16 | 17 | 3) load hiq.tcl with wish 18 | 19 | 4) run 20 | 21 | 5) eval "update", keep eval window open 22 | 23 | 6) step, update, step, update, step-out, step-in, run 24 | 25 | 7) demostrate how pegs are moved in the app 26 | 27 | add breakpoint on line 94 of hiqGUI.tcl 28 | 29 | 8) drag a peg & drop over blue 30 | 31 | step-in repeatedly 32 | 33 | 9) drag a peg & drop over illegal hole 34 | 35 | 10) drag a peg & drop over legal hole 36 | 37 | 11) press undo move 38 | 39 | check proc win for *new* 40 | 41 | press "supress and break" 42 | 43 | eval new_message $w "undid!!!" 44 | 45 | eval update 46 | 47 | 12) drag a peg & drop peg 48 | 49 | disable bpt 50 | 51 | drag a peg & drop peg 52 | 53 | 13) demonstrate "restart" 54 | 55 | add bpt to line 212 of hiqState.tcl 56 | 57 | press restart 58 | 59 | see multiple stacks 60 | 61 | 62 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | The TclPro Debugger version 2.0 is an upgrade of of the debugger included in the 2 | TclPro product version 1.5 released and open-sourced by Scriptics Corporation. 3 | 4 | To install: You will need to install the extension in lib/tclparser to add the parse command to Tcl. 5 | 6 | cd lib/tclparser && autoreconf && ./configure && make install 7 | 8 | To run: execute the file bin/prodebug 9 | 10 | The Help menu item on the Debugger's menu bar has an option to open the TclPro 11 | user's guide, which will appear as a PDF file in the user's default browser. 12 | The information in the chapter on the Debugger is still valid. 13 | 14 | The debugger code has been upgraded to function with up-to-date releases of 15 | Tcl/Tk (i.e., versions 8.5, 8.6): 16 | 17 | 18 | * Tk GUI code upgraded to work with current Tk API. 19 | 20 | * Upgraded OS interaction code to work with current operating system releases. 21 | 22 | * Instrumentation code added to accomodate the expand operator. 23 | 24 | * Code added for proper custom instrumentation of new Tcl commands (e.g. apply, 25 | dict, try) and subcommands. 26 | 27 | * Put remote-debugging client code file into package for ease of access. 28 | 29 | * Cleanup and correction of doc files. 30 | 31 | * Files and directories re-arranged into starkit-ready format. 32 | 33 | * Added script to wrap debugger code into a starkit of minimum size. 34 | 35 | * Miscellaneous bug fixes. 36 | -------------------------------------------------------------------------------- /demos/fac/fac.tcl: -------------------------------------------------------------------------------- 1 | # fac.tcl -- 2 | # 3 | # This program takes a command line argument and prints the 4 | # factorial of each integer between 1 and itself. 5 | # 6 | # Copyright (c) 1998 Scriptics Corporation 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: fac.tcl,v 1.2 2000/10/31 23:31:08 welch Exp $ 10 | 11 | # factorial -- 12 | # 13 | # Tail-recursive implementation of the factorial function. 14 | # As a side-effect, the global value of "n" is decremented. 15 | # 16 | 17 | proc factorial {result} { 18 | global n 19 | if {$n <= 1} { 20 | return $result 21 | } 22 | set result [expr {$n * $result}] 23 | incr n -1 24 | return [factorial $result] 25 | } 26 | 27 | # 28 | # Set max to the value of the command line argument. 29 | # 30 | 31 | if {$argc != 1} { 32 | error "this program requires 1 integer as a command line arg" 33 | } 34 | set max [lindex $argv 0] 35 | 36 | # 37 | # Call the factorial procedure for each integer from max down to 1. 38 | # Store each result in the fact array. 39 | # 40 | 41 | for {set i $max} {$i >= 1} {incr i -1} { 42 | 43 | set n $i 44 | 45 | set fact($i) [factorial 1] 46 | } 47 | 48 | # 49 | # Print the index and value of each entry in the fact array. 50 | # 51 | 52 | foreach index [lsort -integer [array names fact]] { 53 | puts "fact($index) = $fact($index)" 54 | } 55 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the 4 | # tcldebugger tests. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | if {[info exists ::tcltest::testSingleFile]} { 12 | if {!$::tcltest::testSingleFile} { 13 | set saveOutput $::tcltest::temporaryDirectory 14 | } 15 | } 16 | 17 | lappend auto_path [file join [file dirname [info script]] ..] 18 | package require protest 19 | catch {namespace import ::protest::*} 20 | 21 | if {[info exists saveOutput]} { 22 | set ::tcltest::temporaryDirectory $saveOutput 23 | } 24 | 25 | puts "Temporary files stored in $::tcltest::temporaryDirectory" 26 | set timeCmd {clock format [clock seconds]} 27 | puts stdout "Tests began at [eval $timeCmd]" 28 | 29 | if {$tcl_platform(platform) == "windows"} { 30 | ::protest::testAllFiles "" wish$::protest::currentVersion(Tk-short) 31 | } else { 32 | ::protest::testAllFiles "" wish$::protest::currentVersion(Tk) 33 | } 34 | 35 | set numFailures [llength $::tcltest::failFiles] 36 | 37 | puts stdout "\nTests ended at [eval $timeCmd]" 38 | ::tcltest::cleanupTests 1 39 | 40 | if {$numFailures > 0} { 41 | return -code error -errorcode $numFailures \ 42 | -errorinfo "Found $numFailures test file failures" 43 | } else { 44 | return 45 | } 46 | -------------------------------------------------------------------------------- /demos/tutorials/pulse.tcl: -------------------------------------------------------------------------------- 1 | # pulse.tcl -- 2 | # 3 | # 4 | # Copyright (c) 1999 Scriptics Corporation 5 | # See the file "license.terms" for information on usage and redistribution of this file. 6 | # 7 | 8 | set beats 0 9 | set pending "" 10 | 11 | label .title -text "Total Heartbeats" 12 | label .beats -textvariable beats 13 | 14 | label .scaleTitle -text "Heart Rate" 15 | scale .rate -orient horizontal -from 60 -to 180 -variable rate 16 | 17 | frame .controls 18 | button .controls.start -text "Start" -command {start} 19 | button .controls.stop -text "Stop" -command {stop} 20 | button .controls.clear -text "Clear" -command {clear} 21 | 22 | pack .title -pady 4 -padx 6 23 | pack .beats 24 | pack .scaleTitle -pady 4 -padx 2 25 | pack .rate -padx 2 -fill x 26 | pack .controls -fill x -pady 4 27 | 28 | pack .controls.start -padx 4 -side left -expand yes 29 | pack .controls.stop -padx 4 -side left -expand yes 30 | pack .controls.clear -padx 4 -side left -expand yes 31 | 32 | proc start {} { 33 | global pending 34 | 35 | if {$pending == ""} { 36 | set pending [after idle animate] 37 | } 38 | } 39 | 40 | proc animate {} { 41 | global rate pending beats 42 | 43 | incr beats 44 | set delay [expr {int(60.0/$rate*1000)}] 45 | set pending [after $delay animate] 46 | } 47 | 48 | 49 | proc stop {} { 50 | global pending 51 | 52 | if {$pending != ""} { 53 | after cancel $pending 54 | set pending "" 55 | } 56 | } 57 | 58 | proc clear {} { 59 | global beats 60 | 61 | set beats 0 62 | } 63 | 64 | -------------------------------------------------------------------------------- /demos/uplevel/uplevel.tcl: -------------------------------------------------------------------------------- 1 | # uplevel.tcl -- 2 | # 3 | # This program demonstrates the debugger's display of stack data when 4 | # an application stops in a script invoked via the "uplevel" command. 5 | # 6 | # Copyright (c) 1998 Scriptics Corporation 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: uplevel.tcl,v 1.2 2000/10/31 23:31:13 welch Exp $ 10 | 11 | # factorial -- 12 | # 13 | # Tail-recursive implementation of the factorial function. 14 | # As a side-effect, the global value of "n" is decremented. 15 | # 16 | 17 | proc factorial {result} { 18 | global n 19 | if {$n <= 1} { 20 | return $result 21 | } 22 | set result [expr {$n * $result}] 23 | incr n -1 24 | return [factorial $result] 25 | } 26 | 27 | # populate_fact_array -- 28 | # 29 | # Call the factorial procedure for each integer from 1 to global max. 30 | # Store each result in the global fact array. 31 | # 32 | 33 | proc populate_fact_array {} { 34 | 35 | uplevel \#0 { 36 | 37 | # 38 | # Call the factorial procedure for each integer from 1 to max. 39 | # Store each result in the global fact array. 40 | # 41 | 42 | for {set i 1} {$i <= $max} {incr i 1} { 43 | 44 | set n $i 45 | 46 | set fact($i) [factorial 1] 47 | } 48 | } 49 | } 50 | 51 | set max 5 52 | populate_fact_array 53 | 54 | # 55 | # Print the index and value of each entry in the fact array. 56 | # 57 | 58 | foreach index [lsort [array names fact]] { 59 | puts "fact($index) = $fact($index)" 60 | } 61 | -------------------------------------------------------------------------------- /lib/tcldebugger/uplevel.pdx: -------------------------------------------------------------------------------- 1 | # blend.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the 4 | # TclBlend extension. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the TclBlend extension 12 | 13 | instrument::addExtension 2.0 {parseUplevel} 14 | 15 | namespace eval parseUplevel { 16 | } 17 | 18 | # Register handlers for each of the TclBlend commands 19 | 20 | instrument::addCommand uplevel \ 21 | {parseSimpleArgs 1 -1 parseUplevel::parseUplevelCmd} 22 | 23 | # parseUplevel::parseUplevelCmd -- 24 | # 25 | # This routine wraps the foobar command. 26 | # Parse args of the pattern: 27 | # ?catch exception_pair script ... ? ?finally script? 28 | # 29 | # Arguments: 30 | # tokens The list of word tokens for the current command. 31 | # index The index of the next word to be parsed. 32 | # 33 | # Results: 34 | # Returns the index of the last token + 1 (all have been parsed). 35 | 36 | proc parseUplevel::parseUplevelCmd {tokens index} { 37 | set argc [expr {[llength $tokens] - $index}] 38 | 39 | if {$argc == 1} { 40 | return [instrument::parseSimpleArgs 1 1 {parseBody} $tokens $index] 41 | } elseif {$argc == 2} { 42 | instrument::getLiteral [lindex $tokens $index] literal 43 | if {[regexp {^\#?[0-9]+$} $literal]} { 44 | # If there's a literal level arg, call parseWord on it. 45 | 46 | return [instrument::parseSimpleArgs 2 2 {parseWord parseBody} \ 47 | $tokens $index] 48 | } 49 | } 50 | return [instrument::parseSimpleArgs 1 -1 {parseWord} $tokens $index] 51 | } 52 | -------------------------------------------------------------------------------- /lib/tclparser/tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the Tcl 4 | # tests. Execute it by invoking "source all.test" when running tcltest 5 | # in this directory. 6 | # 7 | # Copyright (c) 1998-2000 Ajuba Solutions 8 | # All rights reserved. 9 | # 10 | # RCS: @(#) $Id: all.tcl,v 1.3 2000/05/30 22:08:51 wart Exp $ 11 | 12 | if {[lsearch [namespace children] ::tcltest] == -1} { 13 | package require tcltest 14 | namespace import ::tcltest::* 15 | } 16 | 17 | if {"[info commands parser]" == ""} { 18 | package require parser 19 | } 20 | 21 | set ::tcltest::testSingleFile false 22 | set ::tcltest::testsDirectory [file dir [info script]] 23 | 24 | puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutable]" 25 | puts stdout "Tests running in working dir: $::tcltest::testsDirectory" 26 | if {[llength $::tcltest::skip] > 0} { 27 | puts stdout "Skipping tests that match: $::tcltest::skip" 28 | } 29 | if {[llength $::tcltest::match] > 0} { 30 | puts stdout "Only running tests that match: $::tcltest::match" 31 | } 32 | 33 | if {[llength $::tcltest::skipFiles] > 0} { 34 | puts stdout "Skipping test files that match: $::tcltest::skipFiles" 35 | } 36 | if {[llength $::tcltest::matchFiles] > 0} { 37 | puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" 38 | } 39 | 40 | set timeCmd {clock format [clock seconds]} 41 | puts stdout "Tests began at [eval $timeCmd]" 42 | 43 | # source each of the specified tests 44 | foreach file [lsort [::tcltest::getMatchingFiles]] { 45 | set tail [file tail $file] 46 | puts stdout $tail 47 | if {[catch {source $file} msg]} { 48 | puts stdout $msg 49 | } 50 | } 51 | 52 | # cleanup 53 | puts stdout "\nTests ended at [eval $timeCmd]" 54 | ::tcltest::cleanupTests 1 55 | return 56 | 57 | -------------------------------------------------------------------------------- /lib/tcldebugger/blend.pdx: -------------------------------------------------------------------------------- 1 | # blend.pdx -- 2 | # 3 | # This file implements the TclPro Debugger extension for the 4 | # TclBlend extension. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Register the TclBlend extension 12 | 13 | instrument::addExtension 2.0 {java} 14 | 15 | namespace eval blend { 16 | } 17 | 18 | # Register handlers for each of the TclBlend commands 19 | 20 | instrument::addCommand java::bind {parseSimpleArgs 1 3 {parseWord parseWord parseBody}} 21 | instrument::addCommand try {parseSimpleArgs 1 -1 blend::parseTry} 22 | instrument::addCommand java::try {parseSimpleArgs 1 -1 blend::parseTry} 23 | 24 | # blend::parseTry -- 25 | # 26 | # This routine wraps the java::try command. 27 | # Parse args of the pattern: 28 | # ?catch exception_pair script ... ? ?finally script? 29 | # 30 | # Arguments: 31 | # tokens The list of word tokens for the current command. 32 | # index The index of the next word to be parsed. 33 | # 34 | # Results: 35 | # Returns the index of the last token + 1 (all have been parsed). 36 | 37 | proc blend::parseTry {tokens index} { 38 | # The first script argument is required. 39 | 40 | set argList [list parseBody] 41 | 42 | set i [expr {$index + 1}] 43 | set argc [llength $tokens] 44 | while {$i < $argc} { 45 | # At this point in the loop, there are 3X + 2 more args. 46 | 47 | if {$i == [expr {$argc - 2}]} { 48 | lappend argList parseWord parseBody 49 | incr i 2 50 | } else { 51 | lappend argList parseWord parseWord parseBody 52 | incr i 3 53 | } 54 | } 55 | 56 | # in case "try" was call with wrong num args, just check the extras 57 | # against parseWord for now--the user will get a Tcl runtime exception. 58 | 59 | lappend argList parseWord 60 | 61 | return [instrument::parseSimpleArgs 1 -1 $argList $tokens $index] 62 | } 63 | -------------------------------------------------------------------------------- /lib/tclparser/win/makefile.vc: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------- -*- makefile -*- 2 | # 3 | # Makefile for building tclparser using nmake. 4 | # The nmake build system REQUIRES Tcl 8.6.8 or later. 5 | # 6 | # Basic build, test and install 7 | # nmake /s /nologo /f makefile.vc INSTALLDIR=c:\path\to\tcl 8 | # nmake /s /nologo /f makefile.vc INSTALLDIR=c:\path\to\tcl test 9 | # nmake /s /nologo /f makefile.vc INSTALLDIR=c:\path\to\tcl install 10 | # 11 | # For other build options (debug, static etc.) 12 | # See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for 13 | # detailed documentation. 14 | # 15 | # See the file "license.terms" for information on usage and redistribution 16 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17 | # 18 | #------------------------------------------------------------------------------ 19 | 20 | # The name of the package 21 | PROJECT = tclparser 22 | PRJ_PACKAGE_TCLNAME = parser 23 | 24 | !include "rules-ext.vc" 25 | 26 | # Define the object files and resource file that make up the extension. 27 | # Note the resource file does not makes sense if doing a static library build 28 | # hence it is under that condition. TMP_DIR is the output directory 29 | # defined by rules for object files. 30 | PRJ_OBJS = $(TMP_DIR)\tclparser.obj 31 | 32 | # Define any additional compiler flags that might be required for the project 33 | # PRJ_DEFINES = -D_CRT_SECURE_NO_DEPRECATE 34 | 35 | # Define the standard targets 36 | !include "$(_RULESDIR)\targets.vc" 37 | 38 | # We must define a pkgindex target that will create a pkgIndex.tcl 39 | # file in the $(OUT_DIR) directory. We can just redirect to the 40 | # default-pkgindex target for our sample extension. 41 | pkgindex: default-pkgindex 42 | 43 | # The default install target only installs binaries and scripts so add 44 | # an additional target for our documentation. Note this *adds* a target 45 | # since no commands are listed after it. The original targets for 46 | # install (from targets.vc) will remain. 47 | install: default-install-docs-html 48 | -------------------------------------------------------------------------------- /lib/tcldebugger/result.tcl: -------------------------------------------------------------------------------- 1 | # result.tcl -- 2 | # 3 | # This file implements the command result window. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | namespace eval result { 11 | variable text {} 12 | variable frame {} 13 | } 14 | 15 | # result::createWindow -- 16 | # 17 | # Create the window for displaying command results inside the specified 18 | # master. 19 | # 20 | # Arguments: 21 | # mainDbgWin The toplevel window for the main debugger. 22 | # 23 | # Results: 24 | # The handle to the frame that contains the result window. 25 | 26 | proc result::createWindow {mainDbgWin} { 27 | variable text 28 | variable frame 29 | 30 | set frame [frame $mainDbgWin.frame] 31 | set text [text $frame.text -width 1 -height 1 -bd 2 \ 32 | -relief sunken] 33 | grid $text -row 0 -column 1 -sticky we -pady 1 34 | grid columnconf $frame 1 -weight 1 35 | 36 | # Add a little extra space below the text widget so it looks right with the 37 | # status bar in place. 38 | 39 | grid rowconf $frame 1 -minsize 3 40 | bind $text { 41 | gui::formatText $result::text right 42 | } 43 | 44 | # Set the behavior so we get the standard truncation behavior 45 | gui::setDbgTextBindings $text 46 | 47 | # Add a double-click binding to take us to the data display window 48 | bind $text {inspector::showResult} 49 | 50 | return $frame 51 | } 52 | 53 | proc result::updateWindow {} { 54 | variable text 55 | if {[winfo exists $result::frame] \ 56 | && [winfo ismapped $result::frame]} { 57 | resetWindow 58 | 59 | set result [dbg::getResult [font::get -maxchars]] 60 | set code [lindex $result 0] 61 | 62 | set codes {OK ERROR RETURN BREAK CONTINUE} 63 | 64 | if {$code < [llength $codes]} { 65 | set code [lindex $codes $code] 66 | } 67 | set result [code::mangle [lindex $result 1]] 68 | 69 | $text insert 1.0 "Code: $code\tResult: $result" 70 | gui::formatText $text right 71 | } 72 | return 73 | } 74 | 75 | proc result::resetWindow {} { 76 | variable text 77 | 78 | gui::unsetFormatData $text 79 | $text delete 0.0 end 80 | return 81 | } 82 | -------------------------------------------------------------------------------- /lib/tclparser/license.terms: -------------------------------------------------------------------------------- 1 | This software is copyrighted by the Regents of the University of 2 | California, Sun Microsystems, Inc., Scriptics Corporation, 3 | and other parties. The following terms apply to all files associated 4 | with the software unless explicitly disclaimed in individual files. 5 | 6 | The authors hereby grant permission to use, copy, modify, distribute, 7 | and license this software and its documentation for any purpose, provided 8 | that existing copyright notices are retained in all copies and that this 9 | notice is included verbatim in any distributions. No written agreement, 10 | license, or royalty fee is required for any of the authorized uses. 11 | Modifications to this software may be copyrighted by their authors 12 | and need not follow the licensing terms described here, provided that 13 | the new terms are clearly indicated on the first page of each file where 14 | they apply. 15 | 16 | IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 17 | FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 18 | ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 19 | DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 20 | POSSIBILITY OF SUCH DAMAGE. 21 | 22 | THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 23 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 24 | FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 25 | IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 26 | NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 27 | MODIFICATIONS. 28 | 29 | GOVERNMENT USE: If you are acquiring this software on behalf of the 30 | U.S. government, the Government shall have only "Restricted Rights" 31 | in the software and related documentation as defined in the Federal 32 | Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 33 | are acquiring the software on behalf of the Department of Defense, the 34 | software shall be classified as "Commercial Computer Software" and the 35 | Government shall have only "Restricted Rights" as defined in Clause 36 | 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the 37 | authors grant the U.S. Government and others acting in its behalf 38 | permission to use and distribute the software in accordance with the 39 | terms specified in this license. 40 | -------------------------------------------------------------------------------- /lib/tcldebugger/util.tcl: -------------------------------------------------------------------------------- 1 | # util.tcl -- 2 | # 3 | # This file contains miscellaneous utilities. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | # lassign -- 11 | # 12 | # This function emulates the TclX lassign command. 13 | # 14 | # Arguments: 15 | # valueList A list containing the values to be assigned. 16 | # args The list of variables to be assigned. 17 | # 18 | # Results: 19 | # Returns any values that were not assigned to variables. 20 | 21 | if {[info commands lassign] eq {}} { 22 | 23 | # start lassign proc 24 | proc lassign {valueList args} { 25 | if {[llength $args] == 0} { 26 | error "wrong # args: lassign list varname ?varname..?" 27 | } 28 | 29 | uplevel [list foreach $args $valueList {break}] 30 | return [lrange $valueList [llength $args] end] 31 | } 32 | # end lassign proc 33 | 34 | } 35 | 36 | # matchKeyword -- 37 | # 38 | # Find the unique match for a string in a keyword table and return 39 | # the associated value. 40 | # 41 | # Arguments: 42 | # table A list of keyword/value pairs. 43 | # str The string to match. 44 | # exact If 1, only exact matches are allowed, otherwise unique 45 | # abbreviations are considered valid matches. 46 | # varName The name of a variable that will hold the resulting value. 47 | # 48 | # Results: 49 | # Returns 1 on a successful match, else 0. 50 | 51 | proc matchKeyword {table str exact varName} { 52 | upvar $varName result 53 | if {$str == ""} { 54 | foreach pair $table { 55 | set key [lindex $pair 0] 56 | if {$key == ""} { 57 | set result [lindex $pair 1] 58 | return 1 59 | } 60 | } 61 | return 0 62 | } 63 | if {$exact} { 64 | set end end 65 | } else { 66 | set end [expr {[string length $str] - 1}] 67 | } 68 | set found "" 69 | foreach pair $table { 70 | set key [lindex $pair 0] 71 | if {[string compare $str [string range $key 0 $end]] == 0} { 72 | # If the string matches exactly, return immediately. 73 | 74 | if {$exact || ($end == ([string length $key]-1))} { 75 | set result [lindex $pair 1] 76 | return 1 77 | } else { 78 | lappend found [lindex $pair 1] 79 | } 80 | } 81 | } 82 | if {[llength $found] == 1} { 83 | set result [lindex $found 0] 84 | return 1 85 | } else { 86 | return 0 87 | } 88 | } 89 | 90 | -------------------------------------------------------------------------------- /lib/tcldebugger/appLaunch.tcl: -------------------------------------------------------------------------------- 1 | # appLaunch.tcl -- 2 | # 3 | # This script takes care of initializing the nub and invoking the 4 | # client application script when an application is being launched 5 | # from the debugger. 6 | # 7 | # NOTE: This file is for internal use only and may change without 8 | # notice. The contents should not be modified in any way. 9 | # 10 | # Copyright (c) 1998-2000 Ajuba Solutions 11 | # Copyright (c) 2017 Forward Folio LLC 12 | # See the file "license.terms" for information on usage and redistribution of this file. 13 | # 14 | 15 | # DbgNub_Main -- 16 | # 17 | # Initializes the nub and invokes the client script. 18 | # 19 | # Arguments: 20 | # None. 21 | # 22 | # Results: 23 | # None. 24 | 25 | proc DbgNub_Main {} { 26 | global argc argv0 argv errorCode errorInfo tcl_version 27 | 28 | if {$argc < 4} { 29 | error "$argv0 needs cmd line args: hostname port scriptName data ?args?" 30 | } 31 | 32 | # Parse command line arguments 33 | 34 | set libDir [file dirname $argv0] 35 | set host [lindex $argv 0] 36 | set port [lindex $argv 1] 37 | set script [lindex $argv 2] 38 | set data [lindex $argv 3] 39 | set argList [lrange $argv 4 end] 40 | 41 | # Set up replacement arguments so the client script doesn't see the 42 | # appLaunch arguments. 43 | 44 | set argv0 $script 45 | set argv $argList 46 | set argc [llength $argList] 47 | 48 | if {[info commands tk] == "tk"} { 49 | set appName [lindex [file split $argv0] end] 50 | tk appname $appName 51 | } 52 | 53 | # The following code needs to be kept in sync with initdebug.tcl 54 | 55 | if {[catch {set socket [socket $host $port]}] != 0} { 56 | exit 1 57 | } 58 | fconfigure $socket -blocking 1 -translation binary 59 | 60 | # On 8.1 and later versions we should ensure the socket is not doing 61 | # any encoding translations. 62 | 63 | if {$tcl_version >= 8.1} { 64 | fconfigure $socket -encoding utf-8 65 | } 66 | 67 | # Attach to the debugger as a local app. 68 | 69 | set msg [list HELLO 1.0 $tcl_version $data] 70 | puts $socket [string length $msg] 71 | puts -nonewline $socket $msg 72 | flush $socket 73 | 74 | # Get the rest of the nub library and evaluate it in the current scope. 75 | # Note that the nub code assumes there will be a "socket" variable that 76 | # contains the debugger socket channel. 77 | 78 | if {[gets $socket bytes] == -1} { 79 | exit 1 80 | } 81 | set msg [read $socket $bytes] 82 | eval [lindex $msg 1] 83 | return 84 | } 85 | 86 | DbgNub_Main 87 | source $argv0 88 | -------------------------------------------------------------------------------- /license.terms: -------------------------------------------------------------------------------- 1 | All modifications to files originally released and copyrighted under the license 2 | below are copyrighted by Forward Folio LLC. All license terms below apply to 3 | said modifications. 4 | 5 | Forward Folio LLC 6 | info@forwardfolio.com 7 | 8 | 9 | Original license : 10 | ------------------ 11 | 12 | This software is copyrighted by the Scriptics Corporation 13 | (also known as Ajuba Solutions). The following terms apply to all files associated 14 | with the software unless explicitly disclaimed in individual files. 15 | 16 | The authors hereby grant permission to use, copy, modify, distribute, 17 | and license this software and its documentation for any purpose, provided 18 | that existing copyright notices are retained in all copies and that this 19 | notice is included verbatim in any distributions. No written agreement, 20 | license, or royalty fee is required for any of the authorized uses. 21 | Modifications to this software may be copyrighted by their authors 22 | and need not follow the licensing terms described here, provided that 23 | the new terms are clearly indicated on the first page of each file where 24 | they apply. 25 | 26 | IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 27 | FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 28 | ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 29 | DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | 32 | THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 33 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 34 | FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 35 | IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 36 | NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 37 | MODIFICATIONS. 38 | 39 | GOVERNMENT USE: If you are acquiring this software on behalf of the 40 | U.S. government, the Government shall have only "Restricted Rights" 41 | in the software and related documentation as defined in the Federal 42 | Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 43 | are acquiring the software on behalf of the Department of Defense, the 44 | software shall be classified as "Commercial Computer Software" and the 45 | Government shall have only "Restricted Rights" as defined in Clause 46 | 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the 47 | authors grant the U.S. Government and others acting in its behalf 48 | permission to use and distribute the software in accordance with the 49 | terms specified in this license. 50 | -------------------------------------------------------------------------------- /main.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | # Copyright (c) 2017 Forward Folio LLC 4 | # See the file "license.terms" for information on usage and redistribution of this file. 5 | 6 | # This is the only way to know definitively if a package is available without 7 | # putting "package require" in a catch statement. Catch statement is bad 8 | # because it hides the errors you don't anticipate as well as the ones you do: 9 | if {"starkit" ni [package names]} { 10 | eval [package unknown] starkit 11 | } 12 | 13 | # Now "package names" holds the definitive answer as to whether the desired 14 | # package is available: 15 | if {"starkit" in [package names]} { 16 | package require starkit 17 | 18 | # unset existing state vars in case this is a nested starkit and 19 | # startup has been done before: 20 | unset -nocomplain ::starkit::mode ::starkit::topdir 21 | 22 | ::starkit::startup 23 | 24 | # Starkits predate Tcl modules. Starkit boot doesn't anticipate that 25 | # module paths may lie outside starkit dir, thus losing true 26 | # encapsulation. 27 | # In case this is a starpack, strip out module paths outside the vfs, 28 | # thus ensuring only modules loaded are those within the vfs: 29 | set tpaths [::tcl::tm::path list] 30 | if {$::starkit::mode ne {starpack}} { 31 | set tpaths {} 32 | } 33 | foreach tpath $tpaths { 34 | if {[string first $::starkit::topdir/ $tpath/]} { 35 | ::tcl::tm::path remove $tpath 36 | } 37 | } 38 | 39 | } else { 40 | # Should be possible to run an unwrapped starkit even without starkit 41 | # package. If missing, do the things ::starkit::startup would do: 42 | namespace eval ::starkit { 43 | set topscript [ 44 | file dirname [ 45 | file norm [ 46 | file join [info script] x 47 | ] 48 | ] 49 | ] 50 | variable topdir [file dirname $topscript] 51 | variable mode sourced 52 | if {$topscript eq [ 53 | file dirname [ 54 | file norm [ 55 | file join $::argv0 x 56 | ] 57 | ] 58 | ]} { 59 | variable mode unwrapped 60 | } 61 | } 62 | 63 | if { 64 | [lsearch -exact $::auto_path $::starkit::topdir/lib] < 0 && 65 | [file isdir $::starkit::topdir/lib] 66 | } { 67 | lappend ::auto_path $::starkit::topdir/lib 68 | } 69 | } 70 | 71 | unset -nocomplain tpath tpaths topscript 72 | 73 | # If this is the first starkit started, save state variables in global space 74 | # so that any nested starkit can access them: 75 | if {![info exists topdir]} { 76 | set topdir $::starkit::topdir 77 | set mode $::starkit::mode 78 | } 79 | 80 | # Add module path within package lib path: 81 | ::tcl::tm::path add [file dirname $::starkit::topdir]//[file tail $::starkit::topdir]/lib/tm 82 | 83 | source $::starkit::topdir/src/startup.tcl 84 | 85 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/system.test: -------------------------------------------------------------------------------- 1 | # This file contains tests for the system.tcl file. 2 | # 3 | # Copyright (c) 1999-2000 by Ajuba Solutions. 4 | # Copyright (c) 2017 Forward Folio LLC 5 | # See the file "license.terms" for information on usage and redistribution of this file. 6 | # 7 | 8 | if {[string compare test [info procs test]] == 1} { 9 | lappend auto_path [file join [file dirname [info script]] ..] 10 | package require protest 11 | namespace import ::protest::* 12 | } 13 | 14 | catch {parse} parseMsg 15 | if {[regexp "invalid command" $parseMsg]} { 16 | package require parser 17 | } 18 | 19 | namespace eval debugger { 20 | variable libdir [file dirname [file dirname [info script]]] 21 | } 22 | 23 | # Windows files need .exe extensions 24 | namespace eval system { 25 | variable exeString 26 | if {$tcl_platform(platform) == "windows"} { 27 | set exeString ".exe" 28 | } else { 29 | set exeString "" 30 | } 31 | } 32 | 33 | package require projectInfo 34 | 35 | # Some tests in this file cannot run with a Debug exedir 36 | 37 | set tclTail $::projectInfo::executable(tclsh) 38 | set tkTail $::projectInfo::executable(wish) 39 | 40 | set tclExe [file exists [file join $::protest::executableDirectory \ 41 | "$tclTail$::system::exeString"]] 42 | set tkExe [file exists [file join $::protest::executableDirectory \ 43 | "$tkTail$::system::exeString"]] 44 | 45 | set ::tcltest::testConstraints(skipIfBuild) \ 46 | [expr {[file exists $tclExe]}] 47 | 48 | source [file join $::protest::sourceDirectory system.tcl] 49 | source [file join $::protest::sourceDirectory block.tcl] 50 | source [file join $::protest::sourceDirectory instrument.tcl] 51 | source [file join $::protest::sourceDirectory location.tcl] 52 | source [file join $::protest::sourceDirectory util.tcl] 53 | source [file join $::protest::sourceDirectory image.tcl] 54 | 55 | test system-1.1 {system::getInterps returns correct tclsh} {skipIfBuild} { 56 | set interpList [system::getInterps] 57 | set result $interpList 58 | foreach interp $interpList { 59 | if {[file tail $interp] == $tclTail} { 60 | set result $interp 61 | break 62 | } 63 | } 64 | set result 65 | } [file join [file dirname [info nameofexecutable]] $tclTail] 66 | 67 | test system-1.2 {system::getInterps returns correct wish} {skipIfBuild} { 68 | set interpList [system::getInterps] 69 | set result $interpList 70 | foreach interp $interpList { 71 | if {[file tail $interp] == $tkTail} { 72 | set result $interp 73 | break 74 | } 75 | } 76 | set result 77 | } [file join [file dirname [info nameofexecutable]] $tkTail] 78 | 79 | test system-1.3 {system::setWidgetAttributes sets all colors as 12 digit hex}\ 80 | {unix skipIfBuild} { 81 | # save current color info 82 | set origColor [. cget -bg] 83 | # change the color of . to something whose rgb is small numbers 84 | . configure -bg "#1B005D006C00" 85 | system::setWidgetAttributes 86 | # now make sure each color is 12 digits long, plus the # sign 87 | set result "" 88 | foreach c [array names system::color] { 89 | if {[string length $system::color($c)]!=13} { 90 | lappend result "color($c)=$system::color($c), which is invalid" 91 | } 92 | } 93 | # restore color to original 94 | . configure -bg $origColor 95 | system::setWidgetAttributes 96 | set result 97 | } {} 98 | 99 | # cleanup 100 | cleanupTests 101 | if {[info exists tk_version] && !$tcl_interactive} { 102 | exit 103 | } 104 | -------------------------------------------------------------------------------- /starkit.manifest: -------------------------------------------------------------------------------- 1 | main.tcl 2 | lib/cmdline/pkgIndex.tcl 3 | lib/cmdline/cmdline.tcl 4 | lib/tcldebugger/initdebug.tcl 5 | lib/tcldebugger/coverage.tcl 6 | lib/tcldebugger/tkcon.tcl 7 | lib/tcldebugger/widget.tcl 8 | lib/tcldebugger/procWin.tcl 9 | lib/tcldebugger/block.tcl 10 | lib/tcldebugger/selection.tcl 11 | lib/tcldebugger/instrument.tcl 12 | lib/tcldebugger/toolbar.tcl 13 | lib/tcldebugger/nub.tcl 14 | lib/tcldebugger/guiUtil.tcl 15 | lib/tcldebugger/debugger.tcl 16 | lib/tcldebugger/pref.tcl 17 | lib/tcldebugger/codeWin.tcl 18 | lib/tcldebugger/oratcl.pdx 19 | lib/tcldebugger/break.tcl 20 | lib/tcldebugger/watchWin.tcl 21 | lib/tcldebugger/uplevel.pdx 22 | lib/tcldebugger/bindings.tcl 23 | lib/tcldebugger/blend.pdx 24 | lib/tcldebugger/pkgIndex.tcl 25 | lib/tcldebugger/portWin.tcl 26 | lib/tcldebugger/stackWin.tcl 27 | lib/tcldebugger/proj.tcl 28 | lib/tcldebugger/gui.tcl 29 | lib/tcldebugger/file.tcl 30 | lib/tcldebugger/tabnotebook.tcl 31 | lib/tcldebugger/inspectorWin.tcl 32 | lib/tcldebugger/dbg.tcl 33 | lib/tcldebugger/menu.tcl 34 | lib/tcldebugger/sybtcl.pdx 35 | lib/tcldebugger/tclCom.pdx 36 | lib/tcldebugger/system.tcl 37 | lib/tcldebugger/location.tcl 38 | lib/tcldebugger/prefWin.tcl 39 | lib/tcldebugger/image.tcl 40 | lib/tcldebugger/breakWin.tcl 41 | lib/tcldebugger/tcltest.pdx 42 | lib/tcldebugger/evalWin.tcl 43 | lib/tcldebugger/result.tcl 44 | lib/tcldebugger/appLaunch.tcl 45 | lib/tcldebugger/util.tcl 46 | lib/tcldebugger/icon.tcl 47 | lib/tcldebugger/find.tcl 48 | lib/tcldebugger/projWin.tcl 49 | lib/tcldebugger/images/kill_d.gif 50 | lib/tcldebugger/images/stepresult_d.gif 51 | lib/tcldebugger/images/refresh_d.gif 52 | lib/tcldebugger/images/break_e.gif 53 | lib/tcldebugger/images/current_d.gif 54 | lib/tcldebugger/images/stepover.gif 55 | lib/tcldebugger/images/current_e.gif 56 | lib/tcldebugger/images/stepto_d.gif 57 | lib/tcldebugger/images/win_watch.gif 58 | lib/tcldebugger/images/stepresult.gif 59 | lib/tcldebugger/images/history_mixed.gif 60 | lib/tcldebugger/images/win_proc.gif 61 | lib/tcldebugger/images/var_d.gif 62 | lib/tcldebugger/images/win_cover.gif 63 | lib/tcldebugger/images/go.gif 64 | lib/tcldebugger/images/debugUnixIcon.gif 65 | lib/tcldebugger/images/stop_d.gif 66 | lib/tcldebugger/images/history.gif 67 | lib/tcldebugger/images/kill.gif 68 | lib/tcldebugger/images/history_disable.gif 69 | lib/tcldebugger/images/stop.gif 70 | lib/tcldebugger/images/break_d.gif 71 | lib/tcldebugger/images/stepin.gif 72 | lib/tcldebugger/images/win_eval.gif 73 | lib/tcldebugger/images/stepout_d.gif 74 | lib/tcldebugger/images/stepover_d.gif 75 | lib/tcldebugger/images/restart_d.gif 76 | lib/tcldebugger/images/stepin_d.gif 77 | lib/tcldebugger/images/history_enable.gif 78 | lib/tcldebugger/images/refresh.gif 79 | lib/tcldebugger/images/win_break.gif 80 | lib/tcldebugger/images/break_m.gif 81 | lib/tcldebugger/images/about.gif 82 | lib/tcldebugger/images/combo_arrow.gif 83 | lib/tcldebugger/images/logo.gif 84 | lib/tcldebugger/images/go_d.gif 85 | lib/tcldebugger/images/current_m.gif 86 | lib/tcldebugger/images/var_e.gif 87 | lib/tcldebugger/images/current_v.gif 88 | lib/tcldebugger/images/current.gif 89 | lib/tcldebugger/images/stepto.gif 90 | lib/tcldebugger/images/stepout.gif 91 | lib/tcldebugger/images/restart.gif 92 | lib/tcldebugger/varWin.tcl 93 | lib/tcldebugger/xmlGen.pdx 94 | lib/tcldebugger/font.tcl 95 | lib/remotedebug/initdebug.tcl 96 | lib/remotedebug/pkgIndex.tcl 97 | lib/projectInfo/projectInfo.tcl 98 | lib/projectInfo/pkgIndex.tcl 99 | lib/tclparser/pkgIndex.tcl 100 | lib/tclparser/libtclparser1.8.so 101 | license.terms 102 | src/startup.tcl 103 | src/images/debugUnixIcon.gif 104 | src/images/about.gif 105 | src/images/logo.gif 106 | -------------------------------------------------------------------------------- /lib/tclparser/ChangeLog: -------------------------------------------------------------------------------- 1 | 2007-07-08 Kevin Kenny 2 | 3 | * configure.in: Advanced patchlevel to 1.4.1 4 | * tclParser.c: Added {*} support, and made parser forgiving in the 5 | face of missing 'errorType' and 'term' data from 6 | Tcl_ParseExpr. Silenced several compiler warnings. 7 | Made the package version come from the configurator. 8 | * tests/parse.test: Made several tests TIP-148 compliant. 9 | * tests/parseCmd.test: Made several tests TIP-148 compliant, and 10 | added a test case for {*}. 11 | * configure: Regenerated. 12 | 13 | 2005-03-18 Jeff Hobbs 14 | 15 | * Makefile.in (AR): use @AR@ 16 | * configure, tclconfig/tcl.m4: TEA 3.2 patch update 17 | 18 | 2005-03-17 Jeff Hobbs 19 | 20 | * configure (new): Updated to TEA 3.2 21 | * Makefile.in, configure.in: 22 | * tclconfig/tcl.m4, tests/all.tcl: 23 | * tclconfig/ChangeLog (removed): 24 | 25 | 2003-11-20 David N. Welton 26 | 27 | * doc/parse.n: Added nroff output as a convenience. 28 | 29 | * doc/parse.man: Added doctools man page, to replace old, 30 | outdated, and inaccurate Word file. 31 | 32 | 2003-04-04 Andreas Kupries 33 | 34 | * tclconfig/tcl.m4: Updated to newest tcl.m4, regenerated 35 | configure's. 36 | 37 | 2002-10-15 Andreas Kupries 38 | 39 | * configure.in: Changed to propagate an initial CFLAGS value to 40 | the final definition. A TEA condition (SHARED_BUILD == 1) 41 | squashed it, causing it the build system to loose the 42 | +DAportable we specify for the AS PA-RISC2.2 build host. This is 43 | a problem for _all_ TEA and TEA 2 based configure files. 44 | 45 | 2002-10-04 Andreas Kupries 46 | 47 | * Makefile.in: 48 | * configure.in: 49 | * aclocal.m4: 50 | * tools: 51 | * tclconfig: Rewrote build system to use TEA 2. 52 | 53 | 2001-10-17 Andreas Kupries 54 | 55 | * tclParser.c: Changed name of package from "tclParser" to 56 | "parser". TclXML provides a package called "tclparser" (pure-tcl 57 | parser for xml). Note the different capitalization. There are 58 | also thoughts underway to make [load] and/or [package require] 59 | case-insensitive. Hence the decision to avoid the possible clash 60 | by renaming this package. Note that the bytecode compiler 61 | package is already called "compiler", so there is a precedent 62 | for using such a generic name. This package exposes "the" parser 63 | of the core tcl interpreter. 64 | 65 | 2001-03-14 Karl Lehenbauer 66 | 67 | * mkIndex.tcl.in: Altered Nativepath proc to work correctly with 68 | new Cygwin drive specification syntax when running on Windows. 69 | (Was //d/foo -> D:/foo Now also /cygdrive/d/foo -> D:/foo) 70 | 71 | 2001-03-02 Karl Lehenbauer 72 | 73 | * Changed packageVersion in tclParser.c from 1.0 to 1.4. 74 | This has the nice side-effect of causing mkIndex.tcl 75 | to generate a valid pkgIndex.tcl file (previously 76 | it would not put in the package ifneeded line.) 77 | 78 | 2000-07-31 Brent Welch 79 | 80 | * mkIndex.tcl.in - fixed DLL install/mkIndex for Windows. 81 | 82 | 2000-07-18 Brent Welch 83 | 84 | * Makefile.in - bug fix in install for lib_BINARIES 85 | 86 | 2000-07-18 David Gravereaux 87 | 88 | * tclParser.c: removed #include because #include 89 | will do it anyways. Changed Tcl_InitStubs in Parser_Init() to ask 90 | for 8.1 instead of 8.0 as there won't ever be a a stub-enabled 8.0.6. 91 | 92 | 93 | 2000-07-16 David Gravereaux 94 | 95 | * configure.in: upped version macro to 1.4 96 | -------------------------------------------------------------------------------- /lib/remotedebug/initdebug.tcl: -------------------------------------------------------------------------------- 1 | # prodebug.tcl -- 2 | # 3 | # This file contains the public routines used to start debugging user 4 | # code in a remote application. 5 | # 6 | # Copyright (c) 1998-1999 by Scriptics Corporation. 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | 12 | # 13 | # This file comprises the public interface to the TclPro Debugger for use 14 | # by applications that are not launched directly from the debugger. The 15 | # public interface consists of the two commands "debugger_init" and 16 | # "debugger_eval". A typical application will source this file then invoke 17 | # "debugger_init" to initiate the connection to the debugger. Once 18 | # connected, the application can use the "debugger_eval" command to 19 | # evaluate scripts that the debugger will be able to step through. 20 | # Additionally, various other Tcl commands including "source" and "proc" 21 | # will automatically instrument code. Any blocks of code (e.g. procedure 22 | # bodies) that existed before "debugger_init" was invoked will execute 23 | # without any instrumentation. 24 | # 25 | 26 | 27 | # debugger_init -- 28 | # 29 | # This function initiates a connection to the TclPro Debugger. Files 30 | # that are sourced and procedures that are defined after this 31 | # function completes will be instrumented by the debugger. 32 | # 33 | # Arguments: 34 | # host Name of the host running the debugger. 35 | # port TCP port that the debugger is using. 36 | # 37 | # Results: 38 | # Returns 1 on success and 0 on failure. 39 | 40 | 41 | proc debugger_init {{host 127.0.0.1} {port 2576}} { 42 | global tcl_version 43 | 44 | if {[catch {set socket [socket $host $port]}] != 0} { 45 | return 0 46 | } 47 | fconfigure $socket -blocking 1 -translation binary 48 | 49 | # On 8.1 and later versions we should ensure the socket is not doing 50 | # any encoding translations. 51 | 52 | if {$tcl_version >= 8.1} { 53 | fconfigure $socket -encoding utf-8 54 | } 55 | 56 | # Send the loader and tcl library version 57 | 58 | set msg [list HELLO 1.0 $tcl_version] 59 | puts $socket [string length $msg] 60 | puts -nonewline $socket $msg 61 | flush $socket 62 | 63 | # Get the rest of the nub library and evaluate it in the current scope. 64 | # Note that the nub code assumes there will be a "socket" variable that 65 | # contains the debugger socket channel. 66 | 67 | if {[gets $socket bytes] == -1} { 68 | close $socket 69 | return 0 70 | } 71 | set msg [read $socket $bytes] 72 | eval [lindex $msg 1] 73 | return 1 74 | } 75 | 76 | # debugger_eval -- 77 | # 78 | # Instrument and evaluate a script. This routine is a trivial 79 | # implementation that is replaced when the nub is downloaded. 80 | # 81 | # Arguments: 82 | # args One or more arguments, the last of which must 83 | # be the script to evaluate. 84 | # 85 | # Results: 86 | # Returns the result of evaluating the script. 87 | 88 | proc debugger_eval {args} { 89 | global errorInfo errorCode 90 | set length [llength $args] 91 | if {$length < 1} { 92 | error "wrong # args: should be \"debugger_eval ?options? script\"" 93 | } 94 | set code [catch {uplevel 1 [lindex $args [expr {$length - 1}]]} result] 95 | return -code $code -errorcode $errorCode -errorinfo $errorInfo $result 96 | } 97 | 98 | # debugger_break -- 99 | # 100 | # This command may be inserted in user code to cause a break 101 | # to occur at the location of this command. If the application 102 | # is not connected to the debugger this command is a no-op. 103 | # 104 | # Arguments: 105 | # str (Optional) String that displays in debugger. 106 | # 107 | # Results: 108 | # None. Will send break message to debugger. 109 | 110 | proc debugger_break {{str ""}} { 111 | return 112 | } 113 | -------------------------------------------------------------------------------- /lib/tcldebugger/location.tcl: -------------------------------------------------------------------------------- 1 | # location.tcl -- 2 | # 3 | # This file contains functions that maintain the 4 | # location data structure. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | package provide loc 1.0 12 | namespace eval loc { 13 | # location data type -- 14 | # 15 | # A location encapsulates the state associated with a range of 16 | # bytes within a block of code. Each location is represented by 17 | # a Tcl list of the form {block line range}. The block is 18 | # the block identifier for the code that contains the range. 19 | # The line is the line number of the first byte in the range. 20 | # The range indicates the extent of the location within the 21 | # block in a form suitable for use with the parser. 22 | 23 | } 24 | # end namespace loc 25 | 26 | 27 | # loc::getBlock -- 28 | # 29 | # Returns the block that contains the given location. 30 | # If no such location exists, an error is generated. 31 | # 32 | # Arguments: 33 | # location The code location whose block is returned. 34 | # 35 | # Results: 36 | # Returns the block that contains the given location. 37 | 38 | proc loc::getBlock {location} { 39 | return [lindex $location 0] 40 | } 41 | 42 | 43 | # loc::getLine -- 44 | # 45 | # Returns the line number for the start of the location as an 46 | # offset from the beginning of the block. If no such location 47 | # exists, an error is generated. 48 | # 49 | # Arguments: 50 | # location The code location whose line number is returned. 51 | # 52 | # Results: 53 | # Returns the line number for the start of the location as an 54 | # offset from the beginning of the block. 55 | 56 | proc loc::getLine {location} { 57 | return [lindex $location 1] 58 | } 59 | 60 | # loc::getRange -- 61 | # 62 | # Returns the range for the given location in a form suitable 63 | # for use with the parser interface. If no such location 64 | # exists, an error is generated. 65 | # 66 | # Arguments: 67 | # location The code location whose range is returned. 68 | # 69 | # Results: 70 | # Returns the range for the given location in a form suitable 71 | # for use with the parser interface. 72 | 73 | proc loc::getRange {location} { 74 | variable locArray 75 | 76 | return [lindex $location 2] 77 | } 78 | 79 | # loc::makeLocation -- 80 | # 81 | # Creates a new location based on the block, range, and line values. 82 | # If the block is invalid, an error is generated. Either the range 83 | # or line must be non-empty, otherwise an error is generated. 84 | # 85 | # Arguments: 86 | # block The block containing the location to be created. 87 | # line The line number of the beginning of the location. 88 | # range Optional. A pair of the location's start and length 89 | # byte values. 90 | # 91 | # Results: 92 | # Returns a unique location identifier. 93 | 94 | proc loc::makeLocation {block line {range {}}} { 95 | return [list $block $line $range] 96 | } 97 | 98 | # loc::match -- 99 | # 100 | # Compare two locations to see if the second location is a match 101 | # for the first location. If the first location has no range, then 102 | # it will match all locations with the same line number. If the 103 | # first location has no line number, then it will match all locations 104 | # with the same block. Otherwise it will only match locations that 105 | # have exactly the same block, line and range. 106 | # 107 | # Arguments: 108 | # pattern The location pattern. 109 | # location The location to test. 110 | # 111 | # Results: 112 | # Returns 1 if the location matches the pattern. 113 | 114 | proc loc::match {pattern location} { 115 | # Check for null line. 116 | if {[lindex $pattern 1] == ""} { 117 | return [expr {[string compare [lindex $pattern 0] \ 118 | [lindex $location 0]] == 0}] 119 | } 120 | # Check for null range. 121 | if {[lindex $pattern 2] == ""} { 122 | return [expr {[string compare [lrange $pattern 0 1] \ 123 | [lrange $location 0 1]] == 0}] 124 | } 125 | # Compare the full location. 126 | return [expr {[string compare $pattern $location] == 0}] 127 | } 128 | 129 | -------------------------------------------------------------------------------- /lib/tclparser/win/rules-ext.vc: -------------------------------------------------------------------------------- 1 | # This file should only be included in makefiles for Tcl extensions, 2 | # NOT in the makefile for Tcl itself. 3 | 4 | !ifndef _RULES_EXT_VC 5 | 6 | # We need to run from the directory the parent makefile is located in. 7 | # nmake does not tell us what makefile was used to invoke it so parent 8 | # makefile has to set the MAKEFILEVC macro or we just make a guess and 9 | # warn if we think that is not the case. 10 | !if "$(MAKEFILEVC)" == "" 11 | 12 | !if exist("$(PROJECT).vc") 13 | MAKEFILEVC = $(PROJECT).vc 14 | !elseif exist("makefile.vc") 15 | MAKEFILEVC = makefile.vc 16 | !endif 17 | !endif # "$(MAKEFILEVC)" == "" 18 | 19 | !if !exist("$(MAKEFILEVC)") 20 | MSG = ^ 21 | You must run nmake from the directory containing the project makefile.^ 22 | If you are doing that and getting this message, set the MAKEFILEVC^ 23 | macro to the name of the project makefile. 24 | !message WARNING: $(MSG) 25 | !endif 26 | 27 | !if "$(PROJECT)" == "tcl" 28 | !error The rules-ext.vc file is not intended for Tcl itself. 29 | !endif 30 | 31 | # We extract version numbers using the nmakehlp program. For now use 32 | # the local copy of nmakehlp. Once we locate Tcl, we will use that 33 | # one if it is newer. 34 | !if [$(CC) -nologo "nmakehlp.c" -link -subsystem:console > nul] 35 | !endif 36 | 37 | # First locate the Tcl directory that we are working with. 38 | !if "$(TCLDIR)" != "" 39 | 40 | _RULESDIR = $(TCLDIR:/=\) 41 | 42 | !else 43 | 44 | # If an installation path is specified, that is also the Tcl directory. 45 | # Also Tk never builds against an installed Tcl, it needs Tcl sources 46 | !if defined(INSTALLDIR) && "$(PROJECT)" != "tk" 47 | _RULESDIR=$(INSTALLDIR:/=\) 48 | !else 49 | # Locate Tcl sources 50 | !if [echo _RULESDIR = \> nmakehlp.out] \ 51 | || [nmakehlp -L generic\tcl.h >> nmakehlp.out] 52 | _RULESDIR = ..\..\tcl 53 | !else 54 | !include nmakehlp.out 55 | !endif 56 | 57 | !endif # defined(INSTALLDIR).... 58 | 59 | !endif # ifndef TCLDIR 60 | 61 | # Now look for the targets.vc file under the Tcl root. Note we check this 62 | # file and not rules.vc because the latter also exists on older systems. 63 | !if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl 64 | _RULESDIR = $(_RULESDIR)\lib\nmake 65 | !elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources 66 | _RULESDIR = $(_RULESDIR)\win 67 | !else 68 | # If we have not located Tcl's targets file, most likely we are compiling 69 | # against an older version of Tcl and so must use our own support files. 70 | _RULESDIR = . 71 | !endif 72 | 73 | !if "$(_RULESDIR)" != "." 74 | # Potentially using Tcl's support files. If this extension has its own 75 | # nmake support files, need to compare the versions and pick newer. 76 | 77 | !if exist("rules.vc") # The extension has its own copy 78 | 79 | !if [echo TCL_RULES_MAJOR = \> versions.vc] \ 80 | && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc] 81 | !endif 82 | !if [echo TCL_RULES_MINOR = \>> versions.vc] \ 83 | && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc] 84 | !endif 85 | 86 | !if [echo OUR_RULES_MAJOR = \>> versions.vc] \ 87 | && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc] 88 | !endif 89 | !if [echo OUR_RULES_MINOR = \>> versions.vc] \ 90 | && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc] 91 | !endif 92 | !include versions.vc 93 | # We have a newer version of the support files, use them 94 | !if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR)) 95 | _RULESDIR = . 96 | !endif 97 | 98 | !endif # if exist("rules.vc") 99 | 100 | !endif # if $(_RULESDIR) != "." 101 | 102 | # Let rules.vc know what copy of nmakehlp.c to use. 103 | NMAKEHLPC = $(_RULESDIR)\nmakehlp.c 104 | 105 | # Get rid of our internal defines before calling rules.vc 106 | !undef TCL_RULES_MAJOR 107 | !undef TCL_RULES_MINOR 108 | !undef OUR_RULES_MAJOR 109 | !undef OUR_RULES_MINOR 110 | 111 | !if exist("$(_RULESDIR)\rules.vc") 112 | !message *** Using $(_RULESDIR)\rules.vc 113 | !include "$(_RULESDIR)\rules.vc" 114 | !else 115 | !error *** Could not locate rules.vc in $(_RULESDIR) 116 | !endif 117 | 118 | !endif # _RULES_EXT_VC -------------------------------------------------------------------------------- /lib/tcldebugger/font.tcl: -------------------------------------------------------------------------------- 1 | # font.tcl -- 2 | # 3 | # This file implements the font system that is used by 4 | # all debugger text widgets that require a fixed font. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval font { 12 | variable fontList {} 13 | variable metrics 14 | } 15 | 16 | # font::createFontData -- 17 | # 18 | # Generate a list of fixed fonts on this system. 19 | # 20 | # Arguments: 21 | # None. 22 | # 23 | # Results: 24 | # None. 25 | 26 | proc font::createFontData {} { 27 | variable validFonts 28 | variable fontList 29 | 30 | font create findFixed 31 | set foundFixed 0 32 | set fontList {} 33 | 34 | foreach font [system::getFontList] { 35 | font configure findFixed -family $font -size 10 36 | if {([font metrics findFixed -fixed]) && \ 37 | [font actual findFixed -family] == $font} { 38 | set foundFixed 1 39 | lappend fontList $font 40 | } 41 | } 42 | if {!$foundFixed} { 43 | error "could not locate a fixed font on this system." 44 | } 45 | if {$fontList == {}} { 46 | error "could not find min size a fixed font on this system." 47 | } 48 | set fontList [lsort $fontList] 49 | font delete findFixed 50 | } 51 | 52 | # font::getFonts -- 53 | # 54 | # Return the list of valid fixed fonts. 55 | # 56 | # Arguments: 57 | # None. 58 | # 59 | # Results: 60 | # A list containing valid fonts. 61 | 62 | proc font::getFonts {} { 63 | variable fontList 64 | 65 | if {$fontList == {}} { 66 | font::createFontData 67 | } 68 | return $fontList 69 | } 70 | 71 | # font::configure -- 72 | # 73 | # Set or reset font data the is used by the various widgets. 74 | # 75 | # Arguments: 76 | # font The new font family to use. 77 | # size The requested size of the font. 78 | # 79 | # Results: 80 | # None. The metrics array will be re-initalized with 81 | # new data about the currently selected font. Use the 82 | # font::get command to retrieve font data. 83 | 84 | proc font::configure {font size} { 85 | variable metrics 86 | 87 | set family [font actual [list $font] -family] 88 | if {[lsearch [font names] dbgFixedFont] < 0} { 89 | font create dbgFixedFont -family $family -size $size 90 | font create dbgFixedItalicFont -family $family -size $size \ 91 | -slant italic 92 | font create dbgFixedBoldFont -family $family -size $size -weight bold 93 | } else { 94 | font configure dbgFixedFont -family $family -size $size 95 | font configure dbgFixedItalicFont -family $family -size $size \ 96 | -slant italic 97 | font configure dbgFixedBoldFont -family $family -size $size \ 98 | -weight bold 99 | } 100 | 101 | # Store as much info about the font as possible. Including: 102 | # the actual family and size, font metrics, the same family 103 | # only with italics and bold, and the width of a single 104 | # fixed character. 105 | 106 | if {[info exists metrics]} { 107 | unset metrics 108 | } 109 | array set metrics [font actual dbgFixedFont] 110 | array set metrics [font metrics dbgFixedFont] 111 | set metrics(-font) dbgFixedFont 112 | set metrics(-fontItalic) dbgFixedItalicFont 113 | set metrics(-fontBold) dbgFixedBoldFont 114 | set metrics(-width) [font measure $metrics(-font) "W"] 115 | set metrics(-maxchars) [expr {[winfo screenwidth .]/$metrics(-width)}] 116 | 117 | return [list $font $size] 118 | } 119 | 120 | # font::get -- 121 | # 122 | # Get data about the selected fixed font. 123 | # 124 | # Arguments: 125 | # option An option to request of the font. Valid options are: 126 | # -ascent -descent 127 | # -family -fixed 128 | # -font -fontBold 129 | # -fontItalic -linespace 130 | # -overstrike -size 131 | # -slant -underline 132 | # -weight -width 133 | # 134 | # Results: 135 | # Data about the font or empty string if no data exists. 136 | 137 | proc font::get {option} { 138 | variable metrics 139 | 140 | if {[info exists metrics($option)]} { 141 | return $metrics($option) 142 | } else { 143 | return {} 144 | } 145 | } 146 | 147 | 148 | 149 | 150 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/startup.tcl: -------------------------------------------------------------------------------- 1 | # startup.tcl -- 2 | # 3 | # This file is the primary entry point for the 4 | # TclPro Debugger. 5 | # 6 | # Copyright (c) 1999-2000 by Ajuba Solutions. 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Initialize the debugger library 12 | 13 | package require projectInfo 14 | 15 | # Specify the additional debugger parameters. 16 | 17 | set parameters [list \ 18 | aboutCmd {::TclProAboutBox images/about.gif images/logo.gif} \ 19 | aboutCopyright "$::projectInfo::copyright\nVersion $::projectInfo::patchLevel" \ 20 | appType remote \ 21 | ] 22 | 23 | if {$::tcl_platform(platform) == "windows"} { 24 | package require Winico 25 | lappend parameters iconImage [winico load dbg scicons.dll] 26 | } else { 27 | lappend parameters iconImage images/debugUnixIcon.gif 28 | } 29 | 30 | # ::TclProAboutBox -- 31 | # 32 | # This procedure displays the TclPro about box or 33 | # splash screen. 34 | # 35 | # Arguments: 36 | # image The main image to display in the about box. 37 | # 38 | # Results: 39 | # None. 40 | 41 | proc ::TclProAboutBox {aboutImage logoImage} { 42 | catch {destroy .about} 43 | 44 | # Create an undecorated toplevel with a raised bevel 45 | set top [toplevel .about -bd 4 -relief raised] 46 | wm overrideredirect .about 1 47 | 48 | # This is a hack to get around a Tk bug. Once Tk is fixed, we can 49 | # let the geometry computations happen off-screen 50 | wm geom .about 1x1 51 | # wm withdraw .about 52 | 53 | # Create a container frame so we can set the background without 54 | # affecting the color of the outermost bevel. 55 | set f1 [frame .about.f -bg white] 56 | pack $f1 -fill both 57 | 58 | # Create the images 59 | 60 | image create photo about -file $aboutImage 61 | image create photo logo -file $logoImage 62 | 63 | # Compute various metrics 64 | set logoWidth [image width logo] 65 | set aboutWidth [image width about] 66 | set screenWidth [winfo screenwidth .] 67 | set screenHeight [winfo screenheight .] 68 | 69 | label $f1.about -bd 0 -bg white -padx 0 -pady 0 -highlightthickness 0 \ 70 | -image about 71 | pack $f1.about -side top -anchor nw 72 | 73 | set f2 [frame $f1.f2 -bg white -bd 0] 74 | pack $f2 -padx 6 -pady 6 -side bottom -fill both -expand 1 75 | 76 | label $f2.logo -bd 0 -bg white -padx 0 -pady 0 -highlightthickness 0 \ 77 | -image logo 78 | pack $f2.logo -side left -anchor nw -padx 0 -pady 0 79 | 80 | set okBut [button $f2.ok -text "OK" -width 6 -default active \ 81 | -command {destroy .about}] 82 | pack $okBut -side right -anchor se -padx 0 -pady 0 83 | 84 | label $f2.version -bd 0 -bg white -padx 10 -pady 0 -highlightthickness 0 \ 85 | -text $::debugger::parameters(aboutCopyright) -justify left 86 | pack $f2.version -side top -anchor nw 87 | 88 | label $f2.url -bd 0 -bg white -padx 10 -pady 0 -highlightthickness 0 \ 89 | -text "http://www.scriptics.com" -fg blue \ 90 | -cursor hand2 91 | pack $f2.url -side top -anchor nw 92 | 93 | # Establish dialog bindings 94 | 95 | bind .about <1> { 96 | raise .about 97 | } 98 | bind $f2.url { 99 | destroy .about 100 | system::openURL http://www.scriptics.com 101 | } 102 | bind .about "$okBut invoke" 103 | 104 | # Add the Windows-only console hack 105 | 106 | if {$::tcl_platform(platform) == "windows"} { 107 | bind $okBut { 108 | console show 109 | destroy .about; break 110 | } 111 | } 112 | 113 | # Place the window in the center of the screen 114 | update 115 | set width [winfo reqwidth .about] 116 | set height [winfo reqheight .about] 117 | set x [expr {([winfo screenwidth .]/2) - ($width/2)}] 118 | set y [expr {([winfo screenheight .]/2) - ($height/2)}] 119 | wm deiconify .about 120 | wm geom .about ${width}x${height}+${x}+${y} 121 | 122 | catch { 123 | focus -force $okBut 124 | grab -global .about 125 | } 126 | 127 | # Return the about window so we can destroy it from external bindings 128 | # if necessary. 129 | return .about 130 | } 131 | 132 | 133 | package require debugger 134 | debugger::init $argv $parameters 135 | 136 | # Add the TclPro debugger extensions 137 | 138 | #Source xmlview.tcl 139 | 140 | # Enter the event loop. 141 | -------------------------------------------------------------------------------- /lib/tcldebugger/image.tcl: -------------------------------------------------------------------------------- 1 | # image.tcl -- 2 | # 3 | # This file is loaded by startup.tcl to populate the image::image 4 | # array with platform dependent pre-loaded image types to be used 5 | # throughout the gui. 6 | # 7 | # Copyright (c) 1998-2000 Ajuba Solutions 8 | # Copyright (c) 2017 Forward Folio LLC 9 | # See the file "license.terms" for information on usage and redistribution of this file. 10 | # 11 | 12 | namespace eval image { 13 | variable image 14 | 15 | # Unix images are of the "photo" type. We store the photo data in 16 | # base64 format (converted from gif format) to aid packaging by 17 | # eliminating binary files. 18 | 19 | 20 | set image(break_disable) [image create photo \ 21 | -file $::debugger::libdir/images/break_d.gif] 22 | set image(break_enable) [image create photo \ 23 | -file $::debugger::libdir/images/break_e.gif] 24 | set image(var_disable) [image create photo \ 25 | -file $::debugger::libdir/images/var_d.gif] 26 | set image(var_enable) [image create photo \ 27 | -file $::debugger::libdir/images/var_e.gif] 28 | set image(comboArrow) [image create photo \ 29 | -file $::debugger::libdir/images/combo_arrow.gif] 30 | set image(current) [image create photo \ 31 | -file $::debugger::libdir/images/current.gif] 32 | set image(current_disable) [image create photo \ 33 | -file $::debugger::libdir/images/current_d.gif] 34 | set image(current_enable) [image create photo \ 35 | -file $::debugger::libdir/images/current_e.gif] 36 | set image(current_var) [image create photo \ 37 | -file $::debugger::libdir/images/current_v.gif] 38 | set image(run_disable) [image create photo \ 39 | -file $::debugger::libdir/images/go_d.gif] 40 | set image(run) [image create photo \ 41 | -file $::debugger::libdir/images/go.gif] 42 | set image(kill_disable) [image create photo \ 43 | -file $::debugger::libdir/images/kill_d.gif] 44 | set image(kill) [image create photo \ 45 | -file $::debugger::libdir/images/kill.gif] 46 | set image(restart_disable) [image create photo \ 47 | -file $::debugger::libdir/images/restart_d.gif] 48 | set image(restart) [image create photo \ 49 | -file $::debugger::libdir/images/restart.gif] 50 | set image(refreshFile_disable) [image create photo \ 51 | -file $::debugger::libdir/images/refresh_d.gif] 52 | set image(refreshFile) [image create photo \ 53 | -file $::debugger::libdir/images/refresh.gif] 54 | set image(into_disable) [image create photo \ 55 | -file $::debugger::libdir/images/stepin_d.gif] 56 | set image(into) [image create photo \ 57 | -file $::debugger::libdir/images/stepin.gif] 58 | set image(out_disable) [image create photo \ 59 | -file $::debugger::libdir/images/stepout_d.gif] 60 | set image(out) [image create photo \ 61 | -file $::debugger::libdir/images/stepout.gif] 62 | set image(over_disable) [image create photo \ 63 | -file $::debugger::libdir/images/stepover_d.gif] 64 | set image(over) [image create photo \ 65 | -file $::debugger::libdir/images/stepover.gif] 66 | set image(stop_disable) [image create photo \ 67 | -file $::debugger::libdir/images/stop_d.gif] 68 | set image(stop) [image create photo \ 69 | -file $::debugger::libdir/images/stop.gif] 70 | set image(history_disable) [image create photo \ 71 | -file $::debugger::libdir/images/history_disable.gif] 72 | set image(history_enable) [image create photo \ 73 | -file $::debugger::libdir/images/history_enable.gif] 74 | set image(history) [image create photo \ 75 | -file $::debugger::libdir/images/history.gif] 76 | set image(to_disable) [image create photo \ 77 | -file $::debugger::libdir/images/stepto_d.gif] 78 | set image(to) [image create photo \ 79 | -file $::debugger::libdir/images/stepto.gif] 80 | set image(cmdresult) [image create photo \ 81 | -file $::debugger::libdir/images/stepresult.gif] 82 | set image(cmdresult_disable) [image create photo \ 83 | -file $::debugger::libdir/images/stepresult_d.gif] 84 | 85 | set image(win_break) [image create photo \ 86 | -file $::debugger::libdir/images/win_break.gif] 87 | set image(win_eval) [image create photo \ 88 | -file $::debugger::libdir/images/win_eval.gif] 89 | set image(win_proc) [image create photo \ 90 | -file $::debugger::libdir/images/win_proc.gif] 91 | set image(win_watch) [image create photo \ 92 | -file $::debugger::libdir/images/win_watch.gif] 93 | set image(win_cover) [image create photo \ 94 | -file $::debugger::libdir/images/win_cover.gif] 95 | 96 | } 97 | -------------------------------------------------------------------------------- /demos/xpm/makeXpm.tcl: -------------------------------------------------------------------------------- 1 | # makeXpm.tcl -- 2 | # 3 | # Alpha Debugger Demo. This file demonstrates variable and stack data in 4 | # the debugger. 5 | # 6 | # Copyright (c) 1998 Scriptics Corporation 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: makeXpm.tcl,v 1.2 2000/10/31 23:31:13 welch Exp $ 10 | 11 | proc red {width} { 12 | 13 | upvar sideSpace space 14 | 15 | set color v 16 | for {set colorCount 0} {$colorCount < $space} {incr colorCount} { 17 | append result $color 18 | } 19 | 20 | set color r 21 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 22 | append result $color 23 | } 24 | orange $width result 25 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 26 | append result $color 27 | } 28 | 29 | set color v 30 | for {set colorCount 0} {$colorCount < $space} {incr colorCount} { 31 | append result $color 32 | } 33 | return $result 34 | } 35 | 36 | proc orange {width var} { 37 | 38 | upvar $var result 39 | set color o 40 | 41 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 42 | append result $color 43 | } 44 | yellow $width result 45 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 46 | append result $color 47 | } 48 | } 49 | 50 | proc yellow {width var} { 51 | 52 | upvar $var result 53 | set color y 54 | 55 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 56 | append result $color 57 | } 58 | green $width result 59 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 60 | append result $color 61 | } 62 | } 63 | 64 | proc green {width var} { 65 | 66 | upvar $var result 67 | set color g 68 | 69 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 70 | append result $color 71 | } 72 | blue $width result 73 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 74 | append result $color 75 | } 76 | } 77 | 78 | proc blue {width var} { 79 | 80 | upvar $var result 81 | set color b 82 | 83 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 84 | append result $color 85 | } 86 | indigo $width result 87 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 88 | append result $color 89 | } 90 | } 91 | 92 | proc indigo {width var} { 93 | 94 | upvar $var result 95 | upvar \#1 centerSpace space 96 | 97 | set color i 98 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 99 | append result $color 100 | } 101 | 102 | if {$space > 0} { 103 | set color v 104 | for {set colorCount 0} {$colorCount < $space} {incr colorCount} { 105 | append result $color 106 | } 107 | set color i 108 | for {set colorCount 0} {$colorCount < $width} {incr colorCount} { 109 | append result $color 110 | } 111 | } 112 | } 113 | 114 | proc writeToFile {fileId repeat} { 115 | 116 | global length width outputFile 117 | 118 | set centerSpace 0 119 | set sideSpace $width 120 | 121 | set fullWidth [expr {$width * $repeat * 13}] 122 | set fullLength [expr {$length * $repeat * 13}] 123 | 124 | puts $fileId "/* XPM */" 125 | puts $fileId "static char * $outputFile\[\] = \{" 126 | puts $fileId "\"$fullWidth $fullLength 7 1\"," 127 | puts $fileId "\"r c #666666660000\", /* medium green */" 128 | puts $fileId "\"o c #666600006666\", /* dark blue */" 129 | puts $fileId "\"y c #000066666666\", /* light grey */" 130 | puts $fileId "\"g c #444400004444\", /* light blue */" 131 | puts $fileId "\"b c #444444440000\", /* medium blue */" 132 | puts $fileId "\"i c #000044444444\", /* medium grey */" 133 | puts $fileId "\"v c #888800008888\", /* dark green */" 134 | 135 | for {set lineNumber 1} {$lineNumber <= $fullLength} {incr lineNumber} { 136 | 137 | puts -nonewline $fileId "\"" 138 | 139 | for {set repeatNumber 0} {$repeatNumber < $repeat} {incr repeatNumber} { 140 | puts -nonewline $fileId [red $width] 141 | } 142 | 143 | if {$lineNumber < $fullLength} { 144 | puts $fileId "\"," 145 | if {[expr {$lineNumber % $length}] == 0} { 146 | set temp $centerSpace 147 | set centerSpace $sideSpace 148 | set sideSpace $temp 149 | } 150 | } 151 | } 152 | puts $fileId "\"\};" 153 | } 154 | 155 | if {$argc == 4} { 156 | 157 | # the following is a nice sequence for the command line args: 158 | # 6 8 4 rainbow.xpm 159 | 160 | set repeat [lindex $argv 0] 161 | set length [lindex $argv 1] 162 | set width [lindex $argv 2] 163 | set outputFile [lindex $argv 3] 164 | } else { 165 | error "command line args required: repetitions length width file" 166 | } 167 | 168 | if {[catch {open $outputFile w} fileId]} { 169 | error "Cannot open $outputFile for writing: $fileId" 170 | } 171 | 172 | writeToFile $fileId $repeat 173 | 174 | close $fileId 175 | 176 | exec xv $outputFile 177 | -------------------------------------------------------------------------------- /lib/tclparser/tests/parseCmd.test: -------------------------------------------------------------------------------- 1 | # This file contains for the parseCmd.c file. 2 | # 3 | # This file contains a collection of tests for one or more of the Tcl 4 | # built-in commands. Sourcing this file into Tcl runs the tests and 5 | # generates output for errors. No output means no errors were found. 6 | # 7 | # Copyright (c) 1998-2000 Ajuba Solutions 8 | # 9 | # See the file "license.terms" for information on usage and redistribution 10 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 | # 12 | # RCS: @(#) $Id: parseCmd.test,v 1.3 2000/05/30 22:08:51 wart Exp $ 13 | 14 | if {[lsearch [namespace children] ::tcltest] == -1} { 15 | package require tcltest 16 | namespace import ::tcltest::* 17 | } 18 | 19 | if {![regexp parse [info commands parse]]} { 20 | puts "parseCmd.test: can't run this test without parse command" 21 | if {[info exists tk_version] && !$tcl_interactive} { 22 | exit 23 | } 24 | return 25 | } 26 | 27 | testConstraint noExpand [catch {concat {*}{foo bar}}] 28 | 29 | test parseCmd-2.1 {ParseCommand} { 30 | list [catch {parse command {set x {foo}z} {}} msg] $msg $errorCode 31 | } {1 {extra characters after close-brace} {PARSE braceExtra 11 {extra characters after close-brace}}} 32 | 33 | test parseCmd-3.1 {ParseSetErrorCode} { 34 | list [catch {parse command {"foo"bar} {}} msg] $msg $errorCode 35 | } {1 {extra characters after close-quote} {PARSE quoteExtra 5 {extra characters after close-quote}}} 36 | test parseCmd-3.2 {ParseSetErrorCode} { 37 | list [catch {parse command {{foo}bar} {}} msg] $msg $errorCode 38 | } {1 {extra characters after close-brace} {PARSE braceExtra 5 {extra characters after close-brace}}} 39 | test parseCmd-3.3 {ParseSetErrorCode} { 40 | list [catch {parse command "{foo}" {0 3}} msg] $msg $errorCode 41 | } {1 {missing close-brace} {PARSE missingBrace 0 {missing close-brace}}} 42 | test parseCmd-3.4 {ParseSetErrorCode} { 43 | list [catch {parse command {[foo} {0 3}} msg] $msg $errorCode 44 | } {1 {missing close-bracket} {PARSE missingBracket 0 {missing close-bracket}}} 45 | test parseCmd-3.5 {ParseSetErrorCode} { 46 | list [catch {parse command {$x(foo)} {0 4}} msg] $msg $errorCode 47 | } {1 {missing )} {PARSE missingParen 2 {missing )}}} 48 | test parseCmd-3.6 {ParseSetErrorCode} { 49 | list [catch {parse command {"foo"} {0 3}} msg] $msg $errorCode 50 | } {1 {missing "} {PARSE missingQuote 0 {missing "}}} 51 | test parseCmd-3.7 {ParseSetErrorCode} { 52 | list [catch {parse command {${foo}} {0 4}} msg] $msg $errorCode 53 | } {1 {missing close-brace for variable name} {PARSE missingVarBrace 1 {missing close-brace for variable name}}} 54 | test parseCmd-3.8 {ParseSetErrorCode} { 55 | list [catch {parse expr {3+err} {}} msg] [lrange $errorCode 0 1] 56 | } {1 {PARSE syntax}} 57 | test parseCmd-3.9 {ParseSetErrorCode} { 58 | list [catch {parse expr {08} {}} msg] [lrange $errorCode 0 1] 59 | } {1 {PARSE badNumber}} 60 | test parseCmd-3.10 {ParseSetErrorCode} { 61 | list [catch {parse expr {} {}} msg] [lrange $errorCode 0 2] 62 | } {1 {PARSE syntax 0}} 63 | 64 | test parseCmd-4.1 {ParseGetString} { 65 | parse getstring "foo\u00c7bar" {5 1} 66 | } b 67 | 68 | test parseCmd-5.1 {ParseCharIndex} { 69 | parse charindex "foo\u00c7bar" {5 1} 70 | } 4 71 | 72 | test parseCmd-6.1 {ParseCharLength} { 73 | parse charlength "foo\u00c7bar" {0 7} 74 | } 6 75 | 76 | test parseCmd-7.1 {parsing {*}} !noExpand { 77 | parse command {concat {*}[foo]} \ 78 | [list 0 [string length {concat {*}{foo bar}}]] 79 | } [list {0 0} {0 15} {15 0} \ 80 | [list [list simple {0 6} \ 81 | [list [list text {0 6} {}]]] \ 82 | [list expand {7 8} \ 83 | [list [list command {10 5} {}]]]]] 84 | 85 | test parseCmd-7.1 {parse list elements} { 86 | set script {0 1 2} 87 | set range {0 end} 88 | set range_str [parse getstring $script $range] 89 | set results [parse list $script $range] 90 | set strs [list] 91 | foreach result $results { 92 | lappend strs [parse getstring $script $result] 93 | } 94 | list $range_str $results $strs 95 | } {{0 1 2} {{0 1} {2 1} {4 1}} {0 1 2}} 96 | 97 | test parseCmd-7.2 {parse list elements} { 98 | set script {{0 1 2}} 99 | set range {1 5} 100 | set range_str [parse getstring $script $range] 101 | set results [parse list $script $range] 102 | set strs [list] 103 | foreach result $results { 104 | lappend strs [parse getstring $script $result] 105 | } 106 | list $range_str $results $strs 107 | } {{0 1 2} {{1 1} {3 1} {5 1}} {0 1 2}} 108 | 109 | test parseCmd-7.3 {parse list elements} { 110 | set script {set i {0 1 2}} 111 | set range {7 5} 112 | set range_str [parse getstring $script $range] 113 | set results [parse list $script $range] 114 | set strs [list] 115 | foreach result $results { 116 | lappend strs [parse getstring $script $result] 117 | } 118 | list $range_str $results $strs 119 | } {{0 1 2} {{7 1} {9 1} {11 1}} {0 1 2}} 120 | 121 | # cleanup 122 | cleanupTests 123 | if {[info exists tk_version] && !$tcl_interactive} { 124 | exit 125 | } 126 | -------------------------------------------------------------------------------- /src/startup.tcl: -------------------------------------------------------------------------------- 1 | # startup.tcl -- 2 | # 3 | # This file is the primary entry point for the 4 | # TclPro Debugger. 5 | # 6 | # Copyright (c) 1999 by Scriptics Corporation. 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Initialize the debugger library 12 | 13 | package require projectInfo 14 | 15 | # Specify the additional debugger parameters. 16 | 17 | set script_dir [file dirname [file norm [info script]]] 18 | set about_gif $script_dir/images/about.gif 19 | set logo_gif $script_dir/images/logo.gif 20 | 21 | set parameters [list \ 22 | aboutCmd "::TclProAboutBox $about_gif $logo_gif" \ 23 | aboutCopyright "$::projectInfo::copyright\nVersion $::projectInfo::patchLevel" \ 24 | appType local \ 25 | ] 26 | 27 | if {0 && $::tcl_platform(platform) == "windows"} { 28 | package require Winico 29 | lappend parameters iconImage [winico load dbg scicons.dll] 30 | } else { 31 | lappend parameters iconImage $script_dir/images/debugUnixIcon.gif 32 | } 33 | 34 | # ::TclProAboutBox -- 35 | # 36 | # This procedure displays the TclPro about box or 37 | # splash screen. 38 | # 39 | # Arguments: 40 | # image The main image to display in the about box. 41 | # 42 | # Results: 43 | # None. 44 | 45 | proc ::TclProAboutBox {aboutImage logoImage} { 46 | catch {destroy .about} 47 | 48 | # Create an undecorated toplevel with a raised bevel 49 | set top [toplevel .about -bd 4 -relief raised] 50 | wm overrideredirect .about 1 51 | 52 | # This is a hack to get around a Tk bug. Once Tk is fixed, we can 53 | # let the geometry computations happen off-screen 54 | wm geom .about 1x1 55 | # wm withdraw .about 56 | 57 | # Create a container frame so we can set the background without 58 | # affecting the color of the outermost bevel. 59 | set f1 [frame .about.f -bg white] 60 | pack $f1 -fill both 61 | 62 | # Create the images 63 | 64 | image create photo about -file $aboutImage 65 | image create photo logo -file $logoImage 66 | 67 | # Compute various metrics 68 | set logoWidth [image width logo] 69 | set aboutWidth [image width about] 70 | set screenWidth [winfo screenwidth .] 71 | set screenHeight [winfo screenheight .] 72 | 73 | label $f1.about -bd 0 -bg white -padx 0 -pady 0 -highlightthickness 0 \ 74 | -image about 75 | pack $f1.about -side top -anchor nw 76 | 77 | set f2 [frame $f1.f2 -bg white -bd 0] 78 | pack $f2 -padx 6 -pady 6 -side bottom -fill both -expand 1 79 | 80 | label $f2.logo -bd 0 -bg white -padx 0 -pady 0 -highlightthickness 0 \ 81 | -image logo 82 | pack $f2.logo -side left -anchor nw -padx 0 -pady 0 83 | 84 | if {0} { 85 | # No room for this 86 | set okBut [button $f2.ok -text "OK" -width 6 -default active \ 87 | -command {destroy .about}] 88 | pack $okBut -side right -anchor se -padx 0 -pady 0 89 | } 90 | 91 | label $f2.version -bd 0 -bg white -padx 10 -pady 0 -highlightthickness 0 \ 92 | -text $::debugger::parameters(aboutCopyright) -justify left 93 | pack $f2.version -side top -anchor nw 94 | 95 | label $f2.url -bd 0 -bg white -padx 10 -pady 0 -highlightthickness 0 \ 96 | -text "http://www.tcl.tk" -fg blue \ 97 | -cursor hand2 98 | pack $f2.url -side top -anchor nw 99 | 100 | # Establish dialog bindings 101 | 102 | bind .about { 103 | destroy .about 104 | } 105 | bind $f2.url { 106 | # destroy .about 107 | system::openURL http://www.tcl.tk/software/tclpro/ 108 | } 109 | bind .about {destroy .about} 110 | 111 | # Add the Windows-only console hack 112 | 113 | if {$::tcl_platform(platform) == "windows"} { 114 | bind .about { 115 | console show 116 | destroy .about; break 117 | } 118 | } 119 | 120 | # Place the window in the center of the screen 121 | update 122 | set width [winfo reqwidth .about] 123 | set height [winfo reqheight .about] 124 | set x [expr {([winfo screenwidth .]/2) - ($width/2)}] 125 | set y [expr {([winfo screenheight .]/2) - ($height/2)}] 126 | wm deiconify .about 127 | wm geom .about ${width}x${height}+${x}+${y} 128 | raise .about 129 | 130 | catch { 131 | focus .about 132 | grab -global .about 133 | } 134 | 135 | # Return the about window so we can destroy it from external bindings 136 | # if necessary. 137 | return .about 138 | } 139 | 140 | if {[catch { 141 | 142 | # This package require loads the debugger and system modules 143 | package require debugger 144 | 145 | # Set TclPro license hook 146 | # package require licenseWin 147 | # licenseWin::verifyLicense 148 | # set ::projectInfo::licenseReleaseProc lclient::release 149 | 150 | debugger::init $argv $parameters 151 | } err]} { 152 | set f [toplevel .init_error] 153 | set l [label $f.label -text "Startup Error"] 154 | set t [text $f.text -width 50 -height 30] 155 | $t insert end $errorInfo 156 | pack $f.text 157 | 158 | if {$::tcl_platform(platform) == "windows"} { 159 | console show 160 | } 161 | } 162 | 163 | # Add the TclPro debugger extensions 164 | 165 | #Source xmlview.tcl 166 | 167 | # Enter the event loop. 168 | -------------------------------------------------------------------------------- /lib/tcldebugger/initdebug.tcl: -------------------------------------------------------------------------------- 1 | # initdebug.tcl -- 2 | # 3 | # This file contains the public routines used to start debugging user 4 | # code in a remote application. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | 12 | # 13 | # This file comprises the public interface to the TclPro Debugger for use 14 | # by applications that are not launched directly from the debugger. The 15 | # public interface consists of the two commands "debugger_init" and 16 | # "debugger_eval". A typical application will source this file then invoke 17 | # "debugger_init" to initiate the connection to the debugger. Once 18 | # connected, the application can use the "debugger_eval" command to 19 | # evaluate scripts that the debugger will be able to step through. 20 | # Additionally, various other Tcl commands including "source" and "proc" 21 | # will automatically instrument code. Any blocks of code (e.g. procedure 22 | # bodies) that existed before "debugger_init" was invoked will execute 23 | # without any instrumentation. 24 | # 25 | 26 | # Avoid redefining these functions in case this file is sourced multiple 27 | # times. This ensures that we only connect to one debugger at a time. 28 | 29 | if {[info commands debugger_init] == ""} { 30 | 31 | # debugger_init -- 32 | # 33 | # This function initiates a connection to the TclPro Debugger. Files 34 | # that are sourced and procedures that are defined after this 35 | # function completes will be instrumented by the debugger. 36 | # 37 | # Arguments: 38 | # host Name of the host running the debugger. 39 | # port TCP port that the debugger is using. 40 | # 41 | # Results: 42 | # Returns 1 on success and 0 on failure. 43 | 44 | 45 | proc debugger_init {{host 127.0.0.1} {port 2576}} { 46 | global tcl_version 47 | 48 | if {[catch {set socket [socket $host $port]}] != 0} { 49 | return 0 50 | } 51 | fconfigure $socket -blocking 1 -translation binary 52 | 53 | # On 8.1 and later versions we should ensure the socket is not doing 54 | # any encoding translations. 55 | 56 | if {$tcl_version >= 8.1} { 57 | fconfigure $socket -encoding utf-8 58 | } 59 | 60 | # Send the loader and tcl library version 61 | 62 | set msg [list HELLO 1.0 $tcl_version] 63 | puts $socket [string length $msg] 64 | puts -nonewline $socket $msg 65 | flush $socket 66 | 67 | # Get the rest of the nub library and evaluate it in the current scope. 68 | # Note that the nub code assumes there will be a "socket" variable that 69 | # contains the debugger socket channel. 70 | 71 | if {[gets $socket bytes] == -1} { 72 | close $socket 73 | return 0 74 | } 75 | set msg [read $socket $bytes] 76 | eval [lindex $msg 1] 77 | return 1 78 | } 79 | 80 | # debugger_eval -- 81 | # 82 | # Instrument and evaluate a script. This routine is a trivial 83 | # implementation that is replaced when the nub is downloaded. 84 | # 85 | # Arguments: 86 | # args One or more arguments, the last of which must 87 | # be the script to evaluate. 88 | # 89 | # Results: 90 | # Returns the result of evaluating the script. 91 | 92 | proc debugger_eval {args} { 93 | global errorInfo errorCode 94 | set length [llength $args] 95 | if {$length < 1} { 96 | error "wrong # args: should be \"debugger_eval ?options? script\"" 97 | } 98 | set code [catch {uplevel 1 [lindex $args [expr {$length - 1}]]} result] 99 | return -code $code -errorcode $errorCode -errorinfo $errorInfo $result 100 | } 101 | 102 | # debugger_break -- 103 | # 104 | # This command may be inserted in user code to cause a break 105 | # to occur at the location of this command. If the application 106 | # is not connected to the debugger this command is a no-op. 107 | # 108 | # Arguments: 109 | # str (Optional) String that displays in debugger. 110 | # 111 | # Results: 112 | # None. Will send break message to debugger. 113 | 114 | proc debugger_break {{str ""}} { 115 | return 116 | } 117 | 118 | # debugger_attached -- 119 | # 120 | # This command may be used to detect if the debugger is 121 | # currently attached to the interpreter. 122 | # 123 | # Arguments: 124 | # None. 125 | # 126 | # Results: 127 | # Returns 1 if the debugger is currently attached. 128 | 129 | proc debugger_attached {} { 130 | return 0 131 | } 132 | 133 | # debugger_setCatchFlag -- 134 | # 135 | # Set the catch flag to indicate if errors should be caught by the 136 | # debugger. This flag is normally set to 0 by the "catch" command. 137 | # This command can be used to reset the flag to allow errors to be 138 | # reported by the debugger even if they would normally be masked by a 139 | # enclosing catch command. Note that the catch flag can be overridden by 140 | # the errorAction flag controlled by the user's project settings. 141 | # 142 | # Arguments: 143 | # flag The new value of the flag. 1 indicates thtat errors should 144 | # be caught by the debugger. 0 indicates that the debugger 145 | # should allow errors to propagate. 146 | # 147 | # Results: 148 | # Returns the previous value of the catch flag. 149 | # 150 | # Side effects: 151 | # None. 152 | 153 | proc debugger_setCatchFlag {flag} { 154 | return 1 155 | } 156 | 157 | 158 | } 159 | -------------------------------------------------------------------------------- /lib/tclparser/doc/parse.man: -------------------------------------------------------------------------------- 1 | [comment {-*- tcl -*- doctools manpage}] 2 | [comment {$Id$}] 3 | [manpage_begin parse n 1.4] 4 | [moddesc {Parse a Tcl script into commands, words, and tokens}] 5 | [titledesc {Parse a Tcl script into commands, words, and tokens.}] 6 | [require Tcl 8] 7 | [require parser [opt 1.4]] 8 | [description] 9 | 10 | [para] 11 | 12 | This command parses a Tcl script into [term "commands, words"] and [term tokens]. 13 | Each of the commands below takes a [term script] to parse and a range 14 | into the script: {[arg first] [arg length]}. The command parses the script from 15 | the first index for [term length] characters. For convenience [term length] 16 | can be set to the value "end". The return of 17 | each command is a list of tuples indicating the ranges of each 18 | sub-element. Use the returned indices as arguments to [cmd "parse getstring"] to 19 | extract the parsed string from the script. 20 | 21 | [para] 22 | 23 | The [cmd parse] command breaks up the script into sequentially smaller 24 | elements. A [term script] contains one or more [term commands]. A [term command] is a set 25 | of [term words] that is terminated by a semicolon, newline or end the of the 26 | script and has no unclosed quotes, braces, brackets or array element 27 | names. A [term word] is a set of characters grouped together by whitespace, 28 | quotes, braces or brackets. Each word is composed of one or more 29 | [term tokens]. A [term token] is one of the following types: [term text], [term variable], 30 | [term backslash], [term command], [term expr], [term operator], or [term expand]. 31 | The type of token specifies how to decompose the string further. For example, a [term text] 32 | token is a literal set of characters that does not need to be broken 33 | into smaller pieces. However, the [term variable] token needs to be broken 34 | into smaller pieces to separate the name of the variable from an array 35 | indices, if one is supplied. 36 | 37 | [para] 38 | 39 | The [term first] index is treated the same way as the indices in 40 | the Tcl [cmd string] command. An index of 0 refers to the first character 41 | of the string. An index of end (or any abbreviation of it) refers to 42 | the last character of the string. If first is less than zero then it 43 | is treated as if it were zero, and if first + length is greater than or equal to 44 | the length of the string then it is treated as if it were end. 45 | 46 | [list_begin definitions] 47 | 48 | [call [cmd parse] command [arg script] {[arg first] [arg length]}] 49 | 50 | Returns a list of indices that partitions the script into [term commands]. 51 | 52 | This routine returns a list of the following form: [term commentRange] 53 | [term commandRange] [term restRange] [term parseTree]. The first range refers to any 54 | leading comments before the command. The second range refers to the 55 | command itself. The third range contains the remainder of the 56 | original range that appears after the command range. The [term parseTree] is 57 | a list representation of the parse tree where each node is a list in 58 | the form: [term type] [term range] [term subTree]. 59 | 60 | [call [cmd parse] expr [arg script] {[arg first] [arg length]}] 61 | 62 | Returns a list that partitions an [term expression] into 63 | subexpressions. The first element of the list is the token type, 64 | [term subexpr], followed by the range of the expressions text, and 65 | finally by a [term subTree] with the words and types of the parse 66 | tree. 67 | 68 | [call [cmd parse] varname [arg script] {[arg first] [arg length]}] 69 | 70 | Returns a list that partitions a [term variable] token into words. 71 | The first element of the list is the token type, [term variable]. The 72 | second is the range of the variable's text, and the third is a subTree 73 | that lists the words and ranges of the variable's components. 74 | 75 | [call [cmd parse] list [arg script] {[arg first] [arg length]}] 76 | 77 | Parses a script as a [term list], returning the range of each element. 78 | [arg script] must be a valid list, or an error will be generated. 79 | 80 | [call [cmd parse] getrange [arg string] [opt [list index length]]] 81 | 82 | Gets the range in bytes of [arg string], optionally beginning at [opt index] 83 | of length [opt length] (both in characters). Equivalent to [cmd "string bytelength"]. 84 | 85 | [call [cmd parse] getstring [arg string] {[arg first] [arg length]}] 86 | 87 | Get the section of [arg string] that corresponds to the specified 88 | range (in bytes). Note that this command must be used instead of [cmd "string range"] 89 | with values returned from the parse commands, because the values are 90 | in bytes, and [cmd "string range"] instead uses characters as its units. 91 | 92 | [call [cmd parse] charindex [arg string] {[arg first] [arg length]}] 93 | 94 | Converts byte oriented index values into character oriented index 95 | values, for the string in question. 96 | 97 | [call [cmd parse] charlength [arg string] {[arg first] [arg length]}] 98 | 99 | Converts the given byte length into a character count, for the string in question. 100 | 101 | [list_end] 102 | 103 | [section EXAMPLES] 104 | 105 | [example { 106 | set script { 107 | while true {puts [getupdate]} 108 | } 109 | 110 | parse command $script {0 end} 111 | }] 112 | 113 | Returns: 114 | 115 | [para] 116 | 117 | {0 0} {5 30} {35 0} {{simple {5 5} {{text {5 5} {}}}} {simple {11 4} {{text {11 4} {}}}} {simple {16 18} {{text {17 16} {}}}}} 118 | 119 | [para] 120 | 121 | Or in other words, a string with no comments, 30 bytes long, beginning 122 | at byte 5. It is composed of a series of subwords, which include 123 | while, true, and {puts [lb]getupdate[rb]}. 124 | 125 | [keywords parse parser] 126 | [manpage_end] 127 | -------------------------------------------------------------------------------- /lib/tcldebugger/file.tcl: -------------------------------------------------------------------------------- 1 | # file.tcl -- 2 | # 3 | # This file implements the file database that maintains 4 | # unique file names and a most-recently-used file list. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval file { 12 | # A list of most-recently-used files in their absolute 13 | # path form. 14 | 15 | variable mruList {} 16 | variable orderedList {} 17 | variable uniqueList {} 18 | 19 | variable updateOrdered 1 20 | variable updateUnique 1 21 | } 22 | 23 | # file::update -- 24 | # 25 | # The list of ordered blocks and unique file names 26 | # is computed lazily and the results are cached 27 | # internally. Call this command when the lists 28 | # need to be re-computed (e.g. after a break.) 29 | # 30 | # Arguments: 31 | # hard Boolean, if true, do a hard update that 32 | # resets the mruList to {}. This should 33 | # only be true when the app is restarted. 34 | # 35 | # Results: 36 | # None. 37 | 38 | proc file::update {{hard 0}} { 39 | variable updateOrdered 1 40 | variable updateUnique 1 41 | if {$hard} { 42 | variable mruList {} 43 | variable orderedList {} 44 | variable uniqueList {} 45 | } 46 | } 47 | 48 | # file::getOrderedBlocks -- 49 | # 50 | # Get an ordered list of open block, where the order 51 | # is most-recently-used, with any remining blocks 52 | # appended to the end. 53 | # 54 | # Arguments: 55 | # None. 56 | # 57 | # Results: 58 | # Returns an ordered list of blocks. The list 59 | # is ordered in a most-recently-used order, then 60 | # any remaining blocks are appended to the end. 61 | 62 | proc file::getOrderedBlocks {} { 63 | variable orderedList 64 | variable updateOrdered 65 | 66 | if {$updateOrdered} { 67 | # Copy the list of MRU blocks into the result. Then 68 | # append any blocks that are not in the MRU list onto 69 | # the end of the new list. 70 | 71 | set orderedList $file::mruList 72 | set blockList [lsort [blk::getFiles]] 73 | foreach block $blockList { 74 | if {[blk::isDynamic $block]} { 75 | continue 76 | } 77 | if {[lsearch -exact $file::mruList $block] < 0} { 78 | lappend orderedList $block 79 | } 80 | } 81 | set updateOrdered 0 82 | } 83 | return $orderedList 84 | } 85 | 86 | # file::getUniqueFiles -- 87 | # 88 | # Get a list of open files where each name is a 89 | # unique name for the file. If there are more than 90 | # one open file with the same name, then the name 91 | # will have a unique identifier. 92 | # 93 | # Arguments: 94 | # None. 95 | # 96 | # Results: 97 | # Returns a list of tuples containing the unique name 98 | # and the block number for the file. The list 99 | # is ordered in a most-recently-used order, then 100 | # any remaining files are appended to the end. 101 | 102 | proc file::getUniqueFiles {} { 103 | variable prevUnique 104 | variable uniqueList 105 | variable updateUnique 106 | 107 | if {$updateUnique} { 108 | set blockList [file::getOrderedBlocks] 109 | set uniqueList {} 110 | foreach block $blockList { 111 | set short [file tail [blk::getFile $block]] 112 | if {[info exists prevUnique($block)]} { 113 | # The file previously recieved a unique 114 | # identifier (i.e "fileName <2>".) To 115 | # maintain consistency, use the old ID. 116 | 117 | set short "$short <$prevUnique($block)>" 118 | } elseif {[info exists unique($short)]} { 119 | # A new file has been loaded that matches 120 | # a previously loaded filename. Bump 121 | # the unique ID and append a unique ID, 122 | # cache the ID for future use. 123 | 124 | incr unique($short) 125 | set prevUnique($block) $unique($short) 126 | set short "$short <$unique($short)>" 127 | } else { 128 | # This is a file w/o a matching name, 129 | # just initialize the unique ID. 130 | 131 | set unique($short) 1 132 | } 133 | lappend uniqueList $short $block 134 | } 135 | set updateUnique 0 136 | } 137 | return $uniqueList 138 | } 139 | 140 | # file::getUniqueFile -- 141 | # 142 | # Get the unique name for the block. 143 | # 144 | # Arguments: 145 | # block The block type for the file. 146 | # 147 | # Results: 148 | # The unique name of the block. 149 | 150 | proc file::getUniqueFile {block} { 151 | foreach {file uBlock} [file::getUniqueFiles] { 152 | if {$uBlock == $block} { 153 | return $file 154 | } 155 | } 156 | return "" 157 | } 158 | 159 | # file::pushBlock -- 160 | # 161 | # Push a new block onto the list of most-recently-used 162 | # blocks. 163 | # 164 | # Arguments: 165 | # block The block of the file to push onto the stack. 166 | # 167 | # Results: 168 | # None. 169 | 170 | proc file::pushBlock {block} { 171 | variable mruList 172 | 173 | if {($block != {}) && (![blk::isDynamic $block])} { 174 | if {[set index [lsearch -exact $mruList $block]] >= 0} { 175 | set mruList [lreplace $mruList $index $index] 176 | } 177 | set mruList [linsert $mruList 0 $block] 178 | file::update 179 | } 180 | } 181 | 182 | # file::getUntitledFile -- 183 | # 184 | # Return a filename of where Name is the default name 185 | # to use and N is the first integer that creates a filename the 186 | # doesn't exist in this directory. 187 | # 188 | # Arguments: 189 | # dir The directory to search finding name conflicts. 190 | # name The default name of the file. 191 | # ext The file extension to append to the filename. 192 | # 193 | # Results: 194 | # A string that is the filename to use. The directory is not 195 | # included in the filename. 196 | 197 | proc file::getUntitledFile {dir name ext} { 198 | for {set i 1} {1} {incr i} { 199 | if {![file exists [file join $dir ${name}${i}${ext}]]} { 200 | return ${name}${i}${ext} 201 | } 202 | } 203 | } 204 | 205 | -------------------------------------------------------------------------------- /lib/remotedebug/docs/initdebug.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1998-1999 by Scriptics Corp. 3 | '\" All rights reserved. 4 | '\" 5 | '\" RCS: @(#) $Id: initdebug.n,v 1.1 2000/08/31 18:03:39 hershey Exp $ 6 | '\" 7 | .so man.macros 8 | .TH debugger_init n "1.4" Ajuba "Ajuba Debugger" 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | debugger_init, debugger_eval, debugger_break \- debugging embedded scripts and 13 | debugging remotely. 14 | .SH SYNOPSIS 15 | .nf 16 | \fBdebugger_init\fR ?\fIhost\fR ?\fIport\fR?? 17 | .VS 1.3 18 | .sp 19 | \fBdebugger_eval\fR ?\fIswitches\fR? \fIscript\fR 20 | .VE 1.3 21 | .VS 1.4 22 | .sp 23 | \fBdebugger_attached\fR 24 | .VE 1.4 25 | .sp 26 | \fBdebugger_break\fR ?\fIstr\fR? 27 | .BE 28 | 29 | .SH INTRODUCTION 30 | 31 | The Tcl procedures defined here allow the Ajuba Debugger to be used to 32 | debug remote, embedded and CGI applications. In order for your 33 | application to establish and maintain communication with the 34 | debugger, you must modify your application to source the initdebug.tcl 35 | file and call the \fBdebugger_init\fR and \fBdebugger_eval\fR 36 | procedures. 37 | .PP 38 | 39 | .SH "COMMAND PROCEDURES" 40 | .PP 41 | The following procedures are provided by the debugger library: 42 | .TP 43 | \fBdebugger_init\fR ?\fIhostname\fR ?\fIport\fR?? 44 | Establish the connection with the debugger that is currently 45 | running on \fIhostname\fR and listening on \fIport\fR. By default 46 | \fIhostname\fR is \fBlocalhost\fR and the port is \fB2576\fR. After 47 | the connection has been made, the debugger will instrument any 48 | files that are sourced into the interpreter with the \fBsource\fR 49 | command, or any commands that appear in the arg list of the 50 | \fBdebugger_eval\fR command. The command returns 1 if the connection 51 | was successful and returns 0 if the connection failed. 52 | .VS 1.3 53 | .TP 54 | \fBdebugger_eval\fR ?\fIswitches\fR? \fIscript\fR 55 | The \fBdebugger_eval\fR command instruments and invokes the specified 56 | \fIscript\fR. The \fBdebugger_eval\fR command allows a program to 57 | explicitly instrument a block of code that might not otherwise be 58 | instrumented by the debugger. If the script is not currently 59 | connected to the debugger, \fBdebugger_eval\fR simply evaluates the 60 | script argument. 61 | .PP 62 | .RS 63 | If the initial arguments to \fBdebugger_eval\fR start with \fB\-\fR, then 64 | they are treated as switches. The following switches are currently 65 | supported: 66 | .PP 67 | .TP 15 68 | \fB\-name \fIname\fR 69 | Associate a \fIname\fR with the script. This causes the debugger 70 | to remember breakpoint information as if the script were sourced from 71 | a file of the given \fIname\fR. This feature can be useful in remote 72 | debugger situations, or when evaluating blocks of dynamically 73 | generated code that are used multiple times. By creating a unique 74 | \fIname\fR for each block, the user can set breakpoints in the block 75 | that persist across invocations. 76 | .TP 77 | \fB\-\|\-\fR 78 | Marks the end of switches. The argument following this one will 79 | be treated as \fIscript\fR even if it starts with a \fB\-\fR. 80 | .RE 81 | .VE 1.3 82 | .VS 1.4 83 | .TP 84 | \fBdebugger_attached\fR 85 | The \fBdebugger_attached\fR returns 1 if the script is currently 86 | connected to the debugger. Otherwise it returns 0. 87 | .VE 1.4 88 | .TP 89 | \fBdebugger_break\fR ?\fIstr\fR? 90 | The \fBdebugger_break\fR command will cause a break to occur when 91 | executed. The effect is similar to the effect of a break\-point on 92 | the line containing the \fBdebugger_break\fR command (the only 93 | difference is that \fIstr\fR is evaulated before the break occurs). 94 | When the break occurs a dialog is presented in the debugger's GUI. If 95 | \fIstr\fR is given (and not empty) the value of \fIstr\fR is presented 96 | in the dialog box. If the script is not currently connected to 97 | the debugger, \fBdebugger_break\fR acts as a no\-op. 98 | 99 | .SH EXAMPLES 100 | .PP 101 | The example code below demonstrates the simplest way to establish a remote 102 | connection and debug an entire script remotely. The connection is 103 | established between the local machine and \fBremoteMachine\fR via port 104 | \fB2576\fR. At this point it is assumed that the debugger is running on 105 | \fBremomoteMachine\fR and is listening on port \fB2576\fR. See the 106 | User's Guide or online help system for more information on how 107 | to specify the port that the debugger listens on. The file \fBmain.tcl\fR 108 | is then sourced, which will cause the contents of the file, and any 109 | subsequent sourced files, to become instrumented (unless the 110 | preferences set in the debugger indicate otherwise.) 111 | .PP 112 | .CS 113 | source initdebug.tcl 114 | if {[debugger_init remoteMachine 2576] == 0} { 115 | return "cannot communicate with remoteMachine on port 2576" 116 | } 117 | source main.tcl 118 | .CE 119 | .PP 120 | The next example shows how to control exactly which commands become 121 | instrumented. Establish the connection exactly like the 122 | previous example. The commands that create the variables x, y and z 123 | will not be instrumented and the debugger will not step through 124 | theses lines. The commands that create the variables a, b and c are 125 | inside the \fBdebugger_eval\fR. This causes these commands to be 126 | instrumented and the debugger will step through these commands. 127 | .PP 128 | .CS 129 | source initdebug.tcl 130 | if {[debugger_init remoteMachine 2576] == 0} { 131 | return "cannot communicate with remoteMachine on port 2576" 132 | } 133 | set x 1 134 | set y 2 135 | set z 3 136 | debugger_eval { 137 | set a [expr {$x + 1}] 138 | set b [expr {$y + 1}] 139 | set c [expr {$z + 1}] 140 | } 141 | .CE 142 | .PP 143 | This example is especially relevant when debugging embedded 144 | scripts. Simply add the first two lines to the beginning of the 145 | script and wrap the existing script in a call to \fBdebugger_eval\fR. 146 | 147 | .SH KEYWORDS 148 | remote debugging, debugger_init, debugger_eval, instrument, attach, detach 149 | -------------------------------------------------------------------------------- /demos/hiq/hiqState.tcl: -------------------------------------------------------------------------------- 1 | # hiqState.tcl -- 2 | # 3 | # This file contains procedures that change the state of the game board. 4 | # 5 | # Copyright (c) 1996 Dartmouth College 6 | # Copyright (c) 1998 Scriptics Corporation 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: hiqState.tcl,v 1.2 2000/10/31 23:31:09 welch Exp $ 10 | 11 | 12 | # start_game -- 13 | # 14 | proc start_game {w {restart 0}} { 15 | global list_of_moves 16 | 17 | initialize_board 18 | 19 | # delete old pegs and holes 20 | if {$restart} { 21 | global msg 22 | 23 | $w delete peg 24 | $w delete hole 25 | new_message $w "-----------RESTARTING GAME-----------" 26 | update 27 | after 2000 "new_message $w {restarted game}" 28 | vwait msg 29 | } else { 30 | new_message $w "started new game" 31 | } 32 | 33 | # create pegs and holes 34 | create_pegs_and_holes $w 0 240 40 35 | 36 | # all pegs become visible except the top of the pyramid 37 | $w raise peg 38 | $w delete peg(0,0) 39 | 40 | # reinitialize the list of moves 41 | set list_of_moves {} 42 | } 43 | 44 | # initialize_board -- 45 | # 46 | proc initialize_board {} { 47 | global board 48 | 49 | # the board is full except the top hole 50 | for {set col 0} {$col < 5} {incr col} { 51 | for {set row 0} {$row <= $col} {incr row} { 52 | set board($col,$row) 1 53 | } 54 | } 55 | set board(0,0) 0 56 | } 57 | 58 | # move_peg -- 59 | # 60 | proc move_peg {oldx oldy newx newy} { 61 | global board 62 | 63 | # if the peg jumped into a full hole, return "" 64 | if {$board($newx,$newy) == 1} { 65 | return "" 66 | } 67 | # if the peg was not moved a valid distance, return "" 68 | if {[correct_distance [expr {$newx - $oldx}] \ 69 | [expr {$newy - $oldy}]] == 0} { 70 | return "" 71 | } 72 | # if the peg jumped over an empty hole, return "" 73 | set avgx [expr {($oldx + $newx) / 2}] 74 | set avgy [expr {($oldy + $newy) / 2}] 75 | if {$board($avgx,$avgy) == 0} { 76 | return "" 77 | } 78 | # remove the old piece 79 | set board($oldx,$oldy) 0 80 | # add the new piece 81 | set board($newx,$newy) 1 82 | # remove the piece in between the new and old pieces 83 | set board($avgx,$avgy) 0 84 | 85 | set game_is_over [find_new_moves] 86 | 87 | # return x and y coords of peg to remove and game_is_over bool 88 | return "$avgx $avgy $game_is_over" 89 | } 90 | 91 | # unmove_peg -- 92 | # 93 | proc unmove_peg {oldx oldy newx newy midx midy} { 94 | global board 95 | 96 | # add the old piece 97 | set board($oldx,$oldy) 1 98 | # remove the new piece 99 | set board($newx,$newy) 0 100 | # add the piece in between the new and old pieces 101 | set board($midx,$midy) 1 102 | } 103 | 104 | # find_new_moves -- 105 | # 106 | proc find_new_moves {} { 107 | global board 108 | 109 | # for each peg, 110 | for {set pcol 0} {$pcol < 5} {incr pcol} { 111 | for {set prow 0} {$prow <= $pcol} {incr prow} { 112 | if {$board($pcol,$prow)} { 113 | # for each hole, 114 | for {set hcol 0} {$hcol < 5} {incr hcol} { 115 | for {set hrow 0} {$hrow <= $hcol} {incr hrow} { 116 | if {!$board($hcol,$hrow)} { 117 | set coldiff [expr {$pcol - $hcol}] 118 | set rowdiff [expr {$prow - $hrow}] 119 | set dist [correct_distance $coldiff $rowdiff] 120 | set colavg [expr {($pcol + $hcol) / 2}] 121 | set rowavg [expr {($prow + $hrow) / 2}] 122 | if {$dist && $board($colavg,$rowavg)} { 123 | return 0 124 | } 125 | } 126 | } 127 | } 128 | } 129 | } 130 | } 131 | return 1 132 | } 133 | 134 | # correct_distance -- 135 | # 136 | proc correct_distance {xdiff ydiff} { 137 | 138 | set abs_xdiff [expr {abs($xdiff)}] 139 | set abs_ydiff [expr {abs($ydiff)}] 140 | 141 | # moving horizontally, or 142 | if {($abs_xdiff == 2) && ($ydiff == 0)} {return 1} 143 | 144 | # moving southwest or northeast, or 145 | if {($xdiff == 0) && ($abs_ydiff == 2)} {return 1} 146 | 147 | # moving northwest or southeast 148 | if {$xdiff == $ydiff && $abs_xdiff == 2} {return 1} 149 | 150 | return 0 151 | } 152 | 153 | # undo_move -- 154 | # 155 | proc undo_move {w} { 156 | global list_of_moves color 157 | 158 | set moves [llength $list_of_moves] 159 | 160 | if {!$moves} { 161 | new_message $w "no moves to be undone" 162 | return 163 | } 164 | 165 | incr moves -1 166 | set move_to_undo [lindex $list_of_moves $moves] 167 | set oldrow [lindex $move_to_undo 0] 168 | set oldcol [lindex $move_to_undo 1] 169 | set newrow [lindex $move_to_undo 2] 170 | set newcol [lindex $move_to_undo 3] 171 | set midrow [lindex $move_to_undo 4] 172 | set midcol [lindex $move_to_undo 5] 173 | 174 | # change the peg's tag to reflect the undone move 175 | $w addtag peg($oldrow,$oldcol) withtag peg($newrow,$newcol) 176 | $w dtag peg($newrow,$newcol) peg($newrow,$newcol) 177 | 178 | # move the peg from new to old 179 | set old_coords [$w coords hole($oldrow,$oldcol)] 180 | eval "$w coords peg($oldrow,$oldcol) $old_coords" 181 | 182 | # add the peg that was jumped over 183 | set jumped_coords [$w coords hole($midrow,$midcol)] 184 | newMessage $w "$move_to_undo, $jumped_coords" 185 | $w create oval [lindex $jumped_coords 0] [lindex $jumped_coords 1] \ 186 | [lindex $jumped_coords 2] [lindex $jumped_coords 3] \ 187 | -fill $color(peg) -outline $color(hole) \ 188 | -tags "peg peg($midrow,$midcol)" 189 | 190 | # record the changes to the board 191 | eval "unmove_peg $move_to_undo" 192 | 193 | # remove the move from the list of moves 194 | set list_of_moves [lreplace $list_of_moves $moves $moves] 195 | 196 | new_message $w "undid one move" 197 | } 198 | 199 | # new_message -- 200 | # 201 | # update message at the bottom of the GUI 202 | # 203 | proc new_message {w string} { 204 | global msg 205 | 206 | $w itemconfigure message -text $string 207 | set msg 1 208 | } 209 | 210 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/initdebug.test: -------------------------------------------------------------------------------- 1 | # This file contains tests for the initdebug.tcl file. 2 | # 3 | # This file contains a collection of tests for one or more of the Tcl 4 | # built-in commands. Sourcing this file into Tcl runs the tests and 5 | # generates output for errors. No output means no errors were found. 6 | # 7 | # Copyright (c) 1998-2000 by Ajuba Solutions 8 | # Copyright (c) 2017 Forward Folio LLC 9 | # 10 | # See the file "license.terms" for information on usage and redistribution 11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | # 13 | 14 | if {[string compare test [info procs test]] == 1} { 15 | lappend auto_path [file join [file dirname [info script]] ..] 16 | package require protest 17 | namespace import ::protest::* 18 | } 19 | 20 | catch {parse} parseMsg 21 | if {[regexp "invalid command" $parseMsg]} { 22 | package require parser 23 | } 24 | 25 | if {[string compare testGui [info procs launchDbg]] == 1} { 26 | source [file join [pwd] [file dirname [info script]] dbgLaunch.tcl] 27 | } 28 | 29 | set testFile [file join $::tcltest::temporaryDirectory test.tcl] 30 | set outputFile [file join $::tcltest::temporaryDirectory output] 31 | 32 | file copy -force [file join $::protest::sourceDirectory initdebug.tcl] $::tcltest::temporaryDirectory 33 | 34 | set pwd [pwd] 35 | cd $::protest::sourceDirectory 36 | 37 | proc launchTest {script {bg 0}} { 38 | global testFile 39 | 40 | set pwd [pwd] 41 | cd $::tcltest::temporaryDirectory 42 | makeFile $script $testFile 43 | if {$bg} { 44 | exec [info nameofexecutable] $testFile & 45 | } else { 46 | exec [info nameofexecutable] $testFile 47 | } 48 | cd $pwd 49 | return 50 | } 51 | 52 | test initdebug-1.1 {debugger_init} { 53 | file delete -force $outputFile 54 | launchTest { 55 | set f [open output w] 56 | source initdebug.tcl 57 | puts "SOURCED" 58 | if {[debugger_init]} { 59 | puts $f succeed 60 | } else { 61 | puts $f failed 62 | } 63 | puts "SAVED" 64 | close $f 65 | exit 66 | } 67 | set f [open $::outputFile r] 68 | set result [read $f] 69 | close $f 70 | set result 71 | } "failed\n" 72 | test initdebug-1.2 {debugger_init} { 73 | initDbg 74 | initRemoteProject REMOTE 5321 75 | launchTest { 76 | set f [open output w] 77 | source initdebug.tcl 78 | if {[debugger_init 127.0.0.1 5321]} { 79 | puts $f succeed 80 | } else { 81 | puts $f failed 82 | } 83 | close $f 84 | exit 85 | } 1 86 | set result [waitForApp] ;# Attach 87 | dbg::step run 88 | lappend result [waitForApp] ;# Exit 89 | set f [open $outputFile r] 90 | lappend result [read $f] 91 | close $f 92 | dbg::quit 93 | set result 94 | } "attach exit {succeed\n}" 95 | 96 | test initdebug-2.1 {debugger_eval} { 97 | file delete -force $outputFile 98 | launchTest { 99 | set f [open output w] 100 | source initdebug.tcl 101 | catch {debugger_eval} result 102 | puts $f $result 103 | close $f 104 | exit 105 | } 106 | set f [open $outputFile r] 107 | set result [read $f] 108 | close $f 109 | set result 110 | } {wrong # args: should be "debugger_eval ?options? script" 111 | } 112 | test initdebug-2.2 {debugger_eval} { 113 | file delete -force $outputFile 114 | launchTest { 115 | set f [open output w] 116 | source initdebug.tcl 117 | catch {debugger_eval {set x 2}} result 118 | puts $f $result 119 | puts $f [set x] 120 | close $f 121 | exit 122 | } 123 | set f [open $outputFile r] 124 | set result [read $f] 125 | close $f 126 | set result 127 | } "2\n2\n" 128 | 129 | test initdebug-3.1 {debugger_attached} { 130 | file delete -force $outputFile 131 | launchTest { 132 | set f [open output w] 133 | source initdebug.tcl 134 | set result [debugger_attached] 135 | puts $f $result 136 | close $f 137 | exit 138 | } 139 | set f [open $outputFile r] 140 | set result [read $f] 141 | close $f 142 | set result 143 | } "0\n" 144 | test initdebug-3.2 {debugger_attached} { 145 | initDbg 146 | initRemoteProject REMOTE 5321 147 | launchTest { 148 | set f [open output w] 149 | fconfigure $f -buffering none 150 | source initdebug.tcl 151 | if {[debugger_init 127.0.0.1 5321]} { 152 | puts $f succeed 153 | } else { 154 | puts $f failed 155 | } 156 | puts $f [debugger_attached] 157 | close $f 158 | exit 159 | } 1 160 | 161 | waitForApp 162 | dbg::step run 163 | after 500 164 | dbg::quit 165 | set f [open $outputFile r] 166 | set result [read $f] 167 | close $f 168 | set result 169 | } "succeed\n1\n" 170 | test initdebug-3.3 {debugger_attached} { 171 | initDbg 172 | initRemoteProject REMOTE 5321 173 | launchTest { 174 | set f [open output w] 175 | fconfigure $f -buffering none 176 | source initdebug.tcl 177 | if {[debugger_init 127.0.0.1 5321]} { 178 | puts $f succeed 179 | } else { 180 | puts $f failed 181 | } 182 | puts $f [debugger_attached] 183 | puts $f [debugger_eval {set x eval}] 184 | puts $f [debugger_attached] 185 | close $f 186 | exit 187 | } 1 188 | 189 | waitForApp 190 | dbg::step any 191 | waitForApp 192 | set dbg::appHost {} 193 | dbg::quit 194 | after 500 195 | set f [open $outputFile r] 196 | set result [read $f] 197 | close $f 198 | set result 199 | } "succeed\n1\neval\n0\n" 200 | 201 | test initdebug-4.1 {sentinel, multiple sourcing of initdebug.tcl} { 202 | initDbg 203 | initRemoteProject REMOTE 5321 204 | launchTest { 205 | set f [open output w] 206 | source initdebug.tcl 207 | if {[debugger_init 127.0.0.1 5321]} { 208 | puts $f succeed 209 | puts $f [debugger_attached] 210 | source initdebug.tcl 211 | puts $f [debugger_attached] 212 | } else { 213 | puts $f failed 214 | } 215 | close $f 216 | exit 217 | } 1 218 | set result [waitForApp] ;# Attach 219 | dbg::step run 220 | lappend result [waitForApp] ;# Exit 221 | set f [open $outputFile r] 222 | lappend result [read $f] 223 | close $f 224 | dbg::quit 225 | set result 226 | } "attach exit {succeed 227 | 1 228 | 1 229 | }" 230 | 231 | catch {file delete -force $outputFile} 232 | catch {file delete -force $testFile} 233 | catch {file delete -force [file join $::tcltest::temporaryDirectory initdebug.tcl]} 234 | 235 | cd $pwd 236 | 237 | cleanupTests 238 | 239 | if {[info exists tk_version] && !$tcl_interactive} { 240 | exit 241 | } 242 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/guiLaunch.tcl: -------------------------------------------------------------------------------- 1 | # tests/debugger/guiLaunch.tcl 2 | # 3 | # This file contains functions that that enable test scripts to 4 | # excercise the debugger GUI. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | set odir [pwd] 12 | cd [file dirname [info script]] 13 | cd $::protest::sourceDirectory 14 | 15 | # Load the minimum set of files needed to get the debugger engine working. 16 | 17 | package require projectInfo 18 | package require cmdline 19 | 20 | namespace eval debugger { 21 | variable libdir [pwd] 22 | variable parameters 23 | array set parameters [list \ 24 | aboutImage [file join $libdir images/about.gif] \ 25 | aboutCopyright "testing" \ 26 | appType local \ 27 | iconImage [expr {($::tcl_platform(platform) == "windows") \ 28 | ? "foo" : [file join $libdir images/debugUnixIcon.gif]}]\ 29 | productName "$::projectInfo::productName Debugger"] 30 | 31 | } 32 | 33 | foreach file { 34 | pref.tcl image.tcl system.tcl font.tcl dbg.tcl 35 | break.tcl block.tcl instrument.tcl gui.tcl guiUtil.tcl widget.tcl 36 | bindings.tcl icon.tcl selection.tcl tabnotebook.tcl tkcon.tcl 37 | breakWin.tcl codeWin.tcl coverage.tcl evalWin.tcl file.tcl find.tcl 38 | inspectorWin.tcl menu.tcl prefWin.tcl procWin.tcl 39 | stackWin.tcl toolbar.tcl varWin.tcl watchWin.tcl proj.tcl projWin.tcl 40 | result.tcl portWin.tcl location.tcl util.tcl 41 | } { 42 | source $file 43 | } 44 | 45 | if {[info procs initProject] == {}} { 46 | source [file join [pwd] [file dirname [info script]] initProject.tcl] 47 | } 48 | 49 | cd $odir 50 | 51 | # testGui -- 52 | # 53 | # Test the Debugger's GUI by passing a script to 54 | # be executed in the application, and another script 55 | # to extract the result. 56 | # 57 | # Arguments: 58 | # appScript Script to debug. 59 | # testScript Script to run in debugger's interp. 60 | # 61 | # Results: 62 | # The result of the testScript. 63 | 64 | proc testGui {appScript testScript {setupScript ""}} { 65 | set result {} 66 | set oldpwd [pwd] 67 | 68 | set code [catch { 69 | cd $::protest::sourceDirectory 70 | initGui 71 | 72 | # Launch a project that uses the appScript 73 | 74 | makeFile $appScript \ 75 | [file join $::tcltest::temporaryDirectory dummy.tcl] 76 | initProject "Ray's Breath Smells Like Cat Food.tpj" \ 77 | [file join $::tcltest::temporaryDirectory dummy.tcl] {} . \ 78 | [info nameofexecutable] 79 | 80 | # Run the setupScript to set up special project or debugger state, 81 | # such as adding bpts. 82 | 83 | if {$setupScript != ""} { 84 | set result [uplevel 1 $setupScript] 85 | } 86 | 87 | # Stop at the first command in appScript 88 | 89 | gui::run dbg::step 90 | waitForApp 91 | waitForApp 92 | 93 | # Run the testScript to simulate user actions and introspect on the 94 | # debugger's state. 95 | 96 | set result [uplevel 1 $testScript] 97 | } msg] 98 | 99 | # delete the appScript file, and cleanup the debugger's state. 100 | 101 | quitGui 102 | catch {file delete -force \ 103 | [file join $::tcltest::temporaryDirectory dummy.tcl]} 104 | cleanProjectFiles 105 | cd $oldpwd 106 | 107 | # throw and error or return the result of the testScript. 108 | 109 | if {$code} { 110 | error $msg $::errorInfo $::errorCode 111 | } 112 | return $result 113 | } 114 | 115 | # initGui -- 116 | # 117 | # Initialize the GUI and the nub. 118 | # 119 | # Arguments: 120 | # None. 121 | # 122 | # Results: 123 | # None. 124 | 125 | proc initGui {} { 126 | wm geometry . +0+0 127 | 128 | dbg::register linebreak {eventProc linebreak gui::linebreakHandler} 129 | dbg::register varbreak {eventProc varbreak gui::varbreakHandler} 130 | dbg::register error {eventProc error gui::errorHandler} 131 | dbg::register result {eventProc result gui::resultHandler} 132 | dbg::register attach {eventProc attach gui::attachHandler} 133 | dbg::register exit {eventProc exit {}} 134 | dbg::register cmdresult {eventProc cmdresult gui::cmdresultHandler} 135 | 136 | system::init 137 | font::configure [pref::prefGet fontType] [pref::prefGet fontSize] 138 | 139 | dbg::initialize 140 | 141 | gui::showMainWindow 142 | wm geometry $::gui::gui(mainDbgWin) +0+0 143 | wm deiconify $::gui::gui(mainDbgWin) 144 | return 145 | } 146 | 147 | # quitGui -- 148 | # 149 | # Remove the registered commands. 150 | # 151 | # Arguments: 152 | # None. 153 | # 154 | # Results: 155 | # None. 156 | 157 | proc quitGui {} { 158 | foreach a [after info] { 159 | after cancel $a 160 | } 161 | catch {dbg::quit} 162 | catch {eval destroy [winfo children .]} 163 | file::update 1 164 | catch {unset gui::format} 165 | gui::setCurrentState new 166 | 167 | after 100 168 | 169 | dbg::unregister linebreak {eventProc linebreak gui::linebreakHandler} 170 | dbg::unregister varbreak {eventProc varbreak gui::varbreakHandler} 171 | dbg::unregister error {eventProc error gui::errorHandler} 172 | dbg::unregister result {eventProc result gui::resultHandler} 173 | dbg::unregister attach {eventProc attach gui::attachHandler} 174 | dbg::unregister exit {eventProc exit {}} 175 | dbg::unregister cmdresult {eventProc cmdresult gui::cmdresultHandler} 176 | return 177 | } 178 | 179 | # eventProc -- 180 | # 181 | # The proc that is registered to execute when an event is triggered. 182 | # Sets the global variable Gui_AppStopped to the event to trigger the 183 | # vwait called by the waitForAppp proc. 184 | # 185 | # Arguments: 186 | # None. 187 | # 188 | # Results: 189 | # None. 190 | 191 | proc eventProc {event cmd args} { 192 | global Gui_AppStopped 193 | # puts "EVENT - $event" 194 | if {$cmd != {}} { 195 | if {[catch {eval $cmd $args} msg]} { 196 | puts "Error $::errorInfo" 197 | } 198 | } 199 | set Gui_AppStopped $event 200 | return 201 | } 202 | 203 | # waitForApp -- 204 | # 205 | # Call this proc after dbg::step, dbg::run, dbg::evaluate. Returns 206 | # when the global variable Gui_AppStopped is set by the breakProc 207 | # or exitProc procedures. 208 | # 209 | # Arguments: 210 | # None. 211 | # 212 | # Results: 213 | # None. 214 | 215 | proc waitForApp {} { 216 | global Gui_AppStopped 217 | vwait Gui_AppStopped 218 | return 219 | } 220 | 221 | -------------------------------------------------------------------------------- /lib/tclparser/configure.in: -------------------------------------------------------------------------------- 1 | dnl 2 | dnl Process this file with autoconf to produce a configure script. 3 | dnl 4 | AC_REVISION($Id: configure.in,v 1.14 2005/03/18 01:23:31 hobbs Exp $) 5 | 6 | AC_INIT([tclparser], [1.8]) 7 | 8 | TEA_INIT([3.9]) 9 | 10 | AC_CONFIG_AUX_DIR(tclconfig) 11 | 12 | #-------------------------------------------------------------------- 13 | # Load the tclConfig.sh file 14 | #-------------------------------------------------------------------- 15 | 16 | TEA_PATH_TCLCONFIG 17 | TEA_LOAD_TCLCONFIG 18 | 19 | #----------------------------------------------------------------------- 20 | # Handle the --prefix=... option by defaulting to what Tcl gave. 21 | # Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. 22 | #----------------------------------------------------------------------- 23 | 24 | TEA_PREFIX 25 | 26 | #----------------------------------------------------------------------- 27 | # Standard compiler checks. 28 | # This sets up CC by using the CC env var, or looks for gcc otherwise. 29 | # This also calls AC_PROG_CC, AC_PROG_INSTALL and a few others to create 30 | # the basic setup necessary to compile executables. 31 | #----------------------------------------------------------------------- 32 | 33 | TEA_SETUP_COMPILER 34 | 35 | #----------------------------------------------------------------------- 36 | # Specify the C source files to compile in TEA_ADD_SOURCES, 37 | # public headers that need to be installed in TEA_ADD_HEADERS, 38 | # stub library C source files to compile in TEA_ADD_STUB_SOURCES, 39 | # and runtime Tcl library files in TEA_ADD_TCL_SOURCES. 40 | # This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS 41 | # and PKG_TCL_SOURCES. 42 | #----------------------------------------------------------------------- 43 | 44 | TEA_ADD_SOURCES([tclParser.c]) 45 | TEA_ADD_HEADERS([]) 46 | TEA_ADD_INCLUDES([]) 47 | TEA_ADD_LIBS([]) 48 | TEA_ADD_CFLAGS([]) 49 | TEA_ADD_STUB_SOURCES([]) 50 | TEA_ADD_TCL_SOURCES([]) 51 | 52 | #-------------------------------------------------------------------- 53 | # A few miscellaneous platform-specific items: 54 | # 55 | # We have to define a special symbol for Windows (BUILD_tclparser in this 56 | # case) so that we create the export library with the dll. 57 | # 58 | # Windows creates a few extra files that need to be cleaned up. 59 | # We can add more files to clean if our extension creates any extra 60 | # files in the future. 61 | # 62 | # Define any extra compiler flags in the PACKAGE_CFLAGS variable. 63 | # These will be appended to the current set of compiler flags for 64 | # your system. 65 | #-------------------------------------------------------------------- 66 | 67 | if test "${TEA_PLATFORM}" = "windows" ; then 68 | AC_DEFINE(BUILD_tclparser) 69 | CLEANFILES="pkgIndex.tcl *.lib *.dll *.exp *.ilk *.pdb vc*.pch" 70 | else 71 | CLEANFILES="pkgIndex.tcl" 72 | fi 73 | AC_SUBST(CLEANFILES) 74 | 75 | #-------------------------------------------------------------------- 76 | # __CHANGE__ 77 | # Choose which headers you need. Extension authors should try very 78 | # hard to only rely on the Tcl public header files. Internal headers 79 | # contain private data structures and are subject to change without 80 | # notice. 81 | # This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG 82 | #-------------------------------------------------------------------- 83 | 84 | #TEA_PUBLIC_TCL_HEADERS 85 | TEA_PRIVATE_TCL_HEADERS 86 | 87 | #-------------------------------------------------------------------- 88 | # Check whether --enable-threads or --disable-threads was given. 89 | # So far only Tcl responds to this one. 90 | #-------------------------------------------------------------------- 91 | 92 | TEA_ENABLE_THREADS 93 | 94 | #-------------------------------------------------------------------- 95 | # The statement below defines a collection of symbols related to 96 | # building as a shared library instead of a static library. 97 | #-------------------------------------------------------------------- 98 | 99 | TEA_ENABLE_SHARED 100 | 101 | #-------------------------------------------------------------------- 102 | # This macro figures out what flags to use with the compiler/linker 103 | # when building shared/static debug/optimized objects. This information 104 | # can be taken from the tclConfig.sh file, but this figures it all out. 105 | #-------------------------------------------------------------------- 106 | 107 | TEA_CONFIG_CFLAGS 108 | 109 | #-------------------------------------------------------------------- 110 | # Set the default compiler switches based on the --enable-symbols option. 111 | #-------------------------------------------------------------------- 112 | 113 | TEA_ENABLE_SYMBOLS 114 | 115 | #-------------------------------------------------------------------- 116 | # Everyone should be linking against the Tcl stub library. If you 117 | # can't for some reason, remove this definition. If you aren't using 118 | # stubs, you also need to modify the SHLIB_LD_LIBS setting below to 119 | # link against the non-stubbed Tcl library. 120 | #-------------------------------------------------------------------- 121 | 122 | AC_DEFINE(USE_TCL_STUBS) 123 | 124 | #-------------------------------------------------------------------- 125 | # This macro generates a line to use when building a library. It 126 | # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, 127 | # and TEA_LOAD_TCLCONFIG macros above. 128 | #-------------------------------------------------------------------- 129 | 130 | TEA_MAKE_LIB 131 | 132 | #-------------------------------------------------------------------- 133 | # Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl 134 | # file during the install process. Don't run the TCLSH_PROG through 135 | # ${CYGPATH} because it's being used directly by make. 136 | # Require that we use a tclsh shell version 8.2 or later since earlier 137 | # versions have bugs in the pkg_mkIndex routine. 138 | # Add WISH as well if this is a Tk extension. 139 | #-------------------------------------------------------------------- 140 | 141 | TEA_PROG_TCLSH 142 | 143 | #-------------------------------------------------------------------- 144 | # Finally, substitute all of the various values into the Makefile. 145 | # You may alternatively have a special pkgIndex.tcl.in or other files 146 | # which require substituting th AC variables in. Include these here. 147 | #-------------------------------------------------------------------- 148 | 149 | AC_OUTPUT([Makefile]) 150 | 151 | #-------------------------------------------------------------------- 152 | -------------------------------------------------------------------------------- /demos/hiq/hiqGUI.tcl: -------------------------------------------------------------------------------- 1 | # hiqGUI.tcl -- 2 | # 3 | # GUI code for the Hi-Q game. This file creates the game board window. 4 | # 5 | # Copyright (c) 1996 Dartmouth College 6 | # Copyright (c) 1998 Scriptics Corporation 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | # RCS: @(#) $Id: hiqGUI.tcl,v 1.2 2000/10/31 23:31:09 welch Exp $ 10 | 11 | # pop-up_main_window -- 12 | # 13 | proc pop_up_main_window {} { 14 | global color 15 | 16 | frame .hiq -borderwidth 10 -bg $color(bg) \ 17 | -highlightbackground $color(bg) -highlightcolor $color(bg) ; 18 | 19 | set w .hiq.board 20 | 21 | # create hiq board 22 | canvas $w -height 400 -width 500 -background $color(canvas-bg) \ 23 | -relief groove -highlightt 0 24 | 25 | # create a button frame 26 | frame .hiq.butt_frame -borderwidth 5 -bg $color(bg) \ 27 | -highlightbackground $color(bg) -highlightcolor $color(bg) ; 28 | 29 | # create a restart button 30 | button .hiq.butt_frame.restart -text "Restart" -command "start_game $w 1" \ 31 | -fg $color(button-fg) -activeforeground $color(button-fg) \ 32 | -bg $color(button-bg) -activebackground $color(button-bg) \ 33 | -highlightthickness 0 34 | 35 | # create an undo button 36 | button .hiq.butt_frame.undo -text "Undo" -command "undo_move $w" \ 37 | -fg $color(button-fg) -activeforeground $color(button-fg) \ 38 | -bg $color(button-bg) -activebackground $color(button-bg) \ 39 | -disabledforeground $color(button-fg) -state disabled \ 40 | -highlightthickness 0 41 | 42 | pack $w 43 | focus $w 44 | pack .hiq.butt_frame.restart -side left -padx 5 45 | pack .hiq.butt_frame.undo -side left -padx 5 46 | pack .hiq.butt_frame 47 | pack .hiq 48 | 49 | # draw the triangle 50 | $w create polygon 0 360 250 0 500 360 -fill $color(canvas-fg) 51 | 52 | # create a message object 53 | $w create text 250 385 -fill $color(fg) -tags message 54 | 55 | return $w 56 | } 57 | 58 | # CanvasMark -- 59 | # 60 | 61 | proc CanvasMark {w x y tag} { 62 | global current_peg 63 | 64 | new_message $w "" 65 | $w raise $tag 66 | 67 | set current_peg(oldx) $x 68 | set current_peg(oldy) $y 69 | 70 | set current_peg(x) $x 71 | set current_peg(y) $y 72 | } 73 | 74 | # CanvasDrag -- 75 | # 76 | 77 | proc CanvasDrag {w x y tag} { 78 | global current_peg 79 | 80 | $w move $tag [expr {$x - $current_peg(x)}] [expr {$y - $current_peg(y)}] 81 | set current_peg(x) $x 82 | set current_peg(y) $y 83 | } 84 | 85 | # CanvasDrop -- 86 | # 87 | 88 | proc CanvasDrop {w x y row column} { 89 | global current_peg list_of_moves 90 | 91 | set hole_was_found 0 92 | 93 | foreach num [$w find enclosed \ 94 | [expr {$x - 30}] [expr {$y - 30}] \ 95 | [expr {$x + 30}] [expr {$y + 30}]] { 96 | 97 | set taglist [$w gettags $num] 98 | 99 | if {[lsearch $taglist "hole"] >= 0} { 100 | set newrow [lindex $taglist 1] 101 | set newcolumn [lindex $taglist 2] 102 | 103 | # find the coordinates of the hole 104 | set hole_coords [$w coords $num] 105 | set hole_was_found 1 106 | break 107 | } 108 | } 109 | 110 | # if no hole was found, then error 111 | if {!$hole_was_found} { 112 | new_message $w "peg is not over a hole" 113 | replace_peg $w peg($row,$column) $x $y 114 | return 115 | } 116 | 117 | # if user made an illegal move, then error 118 | set answer [move_peg $row $column $newrow $newcolumn] 119 | if {$answer == ""} { 120 | new_message $w "illegal move" 121 | replace_peg $w peg($row,$column) $x $y 122 | return 123 | } 124 | 125 | # center the peg over the new hole 126 | eval "$w coords peg($row,$column) $hole_coords" 127 | 128 | # change the peg's tag to reflect the move 129 | $w addtag peg($newrow,$newcolumn) withtag peg($row,$column) 130 | $w dtag peg($newrow,$newcolumn) peg($row,$column) 131 | 132 | # remove the peg that was jumped over 133 | set midrow [lindex $answer 0] 134 | set midcolumn [lindex $answer 1] 135 | $w delete peg($midrow,$midcolumn) 136 | 137 | # add this move to the list of moves 138 | lappend list_of_moves \ 139 | [list $row $column $newrow $newcolumn $midrow $midcolumn] 140 | 141 | # if game is over, unbind all pegs 142 | if {[lindex $answer 2]} { 143 | unbind_all_pegs $w 144 | set tally [llength [$w find withtag "peg"]] 145 | if {$tally == 1} { 146 | new_message $w "Game over! You won!!!" 147 | } else { 148 | new_message $w "Game over! You have $tally pegs left." 149 | } 150 | } 151 | } 152 | 153 | # replace_peg -- 154 | # 155 | # put the peg back where it came from 156 | # 157 | proc replace_peg {w tag x y} { 158 | global current_peg 159 | 160 | $w move $tag [expr {$current_peg(oldx) - $x}] \ 161 | [expr {$current_peg(oldy) - $y}] 162 | } 163 | 164 | # bind_peg -- 165 | # 166 | proc bind_peg {w row column tag} { 167 | global color 168 | 169 | .hiq.butt_frame.undo configure -state normal -bg $color(button-bg) 170 | 171 | $w bind $tag "CanvasMark $w %x %y $tag" 172 | $w bind $tag "CanvasDrag $w %x %y $tag" 173 | $w bind $tag "CanvasDrop $w %x %y $row $column" 174 | } 175 | 176 | # unbind_all_pegs -- 177 | # 178 | proc unbind_all_pegs {w} { 179 | global color 180 | 181 | .hiq.butt_frame.undo configure -state disabled -bg $color(button-mute) 182 | 183 | foreach num [$w find withtag "peg"] { 184 | 185 | set tag [lindex [$w gettags $num] 1] 186 | 187 | $w bind $tag {} 188 | $w bind $tag {} 189 | $w bind $tag {} 190 | } 191 | } 192 | 193 | # create_pegs_and_holes -- 194 | # 195 | # add holes to the board 196 | # add pegs to the board (over the wholes) 197 | # bind click-and-drag for each peg 198 | # 199 | proc create_pegs_and_holes {w row x y} { 200 | global color 201 | 202 | for {set column 0; set horiz $x} {$column <= $row} \ 203 | {incr column; incr horiz 100} { 204 | 205 | $w create oval $horiz $y [expr {$horiz + 20}] [expr {$y + 20}] \ 206 | -fill $color(hole) -outline $color(hole) \ 207 | -tags "hole $row $column hole($row,$column)" 208 | 209 | $w create oval $horiz $y [expr {$horiz + 20}] [expr {$y + 20}] \ 210 | -fill $color(peg) -outline $color(hole) \ 211 | -tags "peg peg($row,$column)" 212 | 213 | bind_peg $w $row $column peg($row,$column) 214 | } 215 | if {$row < 4} { 216 | 217 | create_pegs_and_holes $w [expr {$row + 1}] \ 218 | [expr {$x - 50}] [expr {$y + 70}] 219 | } 220 | } 221 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/dbgLaunch.tcl: -------------------------------------------------------------------------------- 1 | # dbgLaunch.tcl 2 | # 3 | # This file contains functions that that enable test scripts to 4 | # excercise the debugger engine and nub without using the GUI. 5 | # 6 | # Copyright (c) 1998-2000 by Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | # Load the minimum set of files needed to get the debugger engine working. 12 | 13 | set odir [pwd] 14 | 15 | cd [file dirname [info script]] 16 | set ::tcltest::testsDirectory [file dirname [pwd]] 17 | 18 | cd $::protest::sourceDirectory 19 | 20 | package require projectInfo 21 | 22 | namespace eval debugger { 23 | variable libdir [pwd] 24 | variable parameters 25 | array set parameters [list \ 26 | aboutImage [file join $libdir images/about.gif] \ 27 | aboutCopyright "testing" \ 28 | appType local \ 29 | iconImage "foo" \ 30 | productName "$::projectInfo::productName Debugger"] 31 | } 32 | 33 | foreach file { 34 | dbg.tcl block.tcl break.tcl coverage.tcl system.tcl 35 | instrument.tcl image.tcl pref.tcl proj.tcl location.tcl util.tcl 36 | } { 37 | source $file 38 | } 39 | 40 | if {[info procs initProject] == {}} { 41 | source [file join [pwd] [file dirname [info script]] initProject.tcl] 42 | } 43 | 44 | cd $odir 45 | 46 | # proj::InitNewProj -- 47 | # 48 | # Override the init routine for projects since it assumes the existence 49 | # of GUI APIs and Windows. 50 | # 51 | # Arguments: 52 | # None. 53 | # 54 | # Results: 55 | # None. 56 | 57 | proc proj::InitNewProj {} { 58 | variable projectOpen 59 | set projectOpen 1 60 | 61 | if {[proj::isRemoteProj]} { 62 | set port [pref::prefGet portRemote] 63 | while {![dbg::setServerPort $port]} { 64 | error "The port you selected is invalid or taken: $port" 65 | } 66 | } 67 | 68 | pref::groupUpdate Project 69 | return 70 | } 71 | 72 | # initDbg -- 73 | # 74 | # Initialize the debugger without launching an application. 75 | # This routine must be called from within the srcs directory. 76 | # 77 | # Arguments: 78 | # None. 79 | # 80 | # Results: 81 | # None. 82 | 83 | proc initDbg {} { 84 | wm geometry . +0+0 85 | 86 | set blk::blockCounter 0 87 | dbg::initialize 88 | 89 | dbg::register linebreak {eventProc linebreak} 90 | dbg::register error {eventProc error} 91 | dbg::register attach {eventProc attach} 92 | dbg::register exit {eventProc exit} 93 | dbg::register cmdresult {eventProc cmdresult} 94 | system::init 95 | return 96 | } 97 | 98 | # quitDbg -- 99 | # 100 | # Stop debugging the application and unregister the eventProcs 101 | # 102 | # Arguments: 103 | # None. 104 | # 105 | # Results: 106 | # None. 107 | 108 | proc quitDbg {} { 109 | catch {dbg::quit; after 100} 110 | dbg::unregister linebreak {eventProc linebreak} 111 | dbg::unregister error {eventProc error} 112 | dbg::unregister attach {eventProc attach} 113 | dbg::unregister exit {eventProc exit} 114 | dbg::unregister cmdresult {eventProc cmdresult} 115 | return 116 | } 117 | 118 | # testDbg -- 119 | # 120 | # Launch the nub on the given script and execute a sequence of 121 | # debugger operations. 122 | # 123 | # Arguments: 124 | # nubScript The script to run in the nub. 125 | # testScript The script to execute in the debugger. 126 | # 127 | # Results: 128 | # Returns the result of the testScript. 129 | 130 | proc testDbg {nubScript testScript {setupScript {}} {exename tclsh}} { 131 | set result {} 132 | set dummy [file join $::tcltest::temporaryDirectory dummy.tcl] 133 | set pwd [pwd] 134 | cd $::protest::sourceDirectory 135 | 136 | set code [catch { 137 | initDbg 138 | makeFile $nubScript $dummy 139 | 140 | # Load the fake project file, extract the app arguments from the 141 | # preferences and set the server listening on some random port. 142 | 143 | if {$::tcl_platform(platform) == "windows"} { 144 | set exeFile ${exename}$::protest::currentVersion(Tcl-short) 145 | } else { 146 | set exeFile ${exename}$::protest::currentVersion(Tcl) 147 | } 148 | initProject MyProject.tpj $dummy {} $::tcltest::temporaryDirectory \ 149 | [findExeFile $exeFile] 150 | set interp [lindex [pref::prefGet appInterpList] 0] 151 | set dir [lindex [pref::prefGet appDirList] 0] 152 | set script [lindex [pref::prefGet appScriptList] 0] 153 | set arg [lindex [pref::prefGet appArgList] 0] 154 | set proj [file tail [proj::getProjectPath]] 155 | dbg::setServerPort random 156 | 157 | # Now run the test script. 158 | set result [uplevel 1 $setupScript] 159 | 160 | # Start the application and wait for the "attach" event. 161 | dbg::start $interp $dir dummy.tcl $arg $proj 162 | waitForApp 163 | 164 | # Step to the first command of the script. 165 | dbg::step any 166 | waitForApp 167 | 168 | # Now run the test script. 169 | set result [uplevel 1 $testScript] 170 | } msg] 171 | 172 | quitDbg 173 | catch {file delete -force $dummy} 174 | cd $pwd 175 | if {$code} { 176 | error $msg $::errorInfo $::errorCode 177 | } 178 | return $result 179 | } 180 | 181 | # launchDbg -- 182 | # 183 | # Start the both the debugger and the application to debug. 184 | # Set up initial communication. 185 | # 186 | # Arguments: 187 | # app Interpreter in which to run scriptFile. 188 | # port Number of port on which to communicate. 189 | # scriptFile File to debug. 190 | # verbose Boolean that decides whether to log activity. 191 | # 192 | # Results: 193 | # Returns the PID of the application. 194 | 195 | proc launchDbg {app scriptFile} { 196 | initDbg 197 | dbg::start $app $::tcltest::temporaryDirectory $scriptFile {} REMOTE 198 | waitForApp 199 | return 200 | } 201 | 202 | # eventProc -- 203 | # 204 | # The proc that is registered to execute when an event is triggered. 205 | # Sets the global variable Dbg_AppStopped to the event to trigger the 206 | # vwait called by the waitForApp proc. 207 | # 208 | # Arguments: 209 | # None. 210 | # 211 | # Results: 212 | # None. 213 | 214 | proc eventProc {event args} { 215 | global Dbg_AppStopped 216 | # puts "EVENT - $event" 217 | set Dbg_AppStopped $event 218 | return 219 | } 220 | 221 | # waitForApp -- 222 | # 223 | # Call this proc after dbg::step, dbg::run, dbg::evaluate. Returns 224 | # when the global variable Dbg_AppStopped is set by the breakProc 225 | # or exitProc procedures. 226 | # 227 | # Arguments: 228 | # None. 229 | # 230 | # Results: 231 | # None. 232 | 233 | proc waitForApp {} { 234 | global Dbg_AppStopped 235 | vwait Dbg_AppStopped 236 | set ret $Dbg_AppStopped 237 | set Dbg_AppStopped "run" 238 | return $ret 239 | } 240 | 241 | -------------------------------------------------------------------------------- /lib/tcldebugger/portWin.tcl: -------------------------------------------------------------------------------- 1 | # portWin.tcl -- 2 | # 3 | # This file defines the APIs needed to display the bad port dialog 4 | # when a user enters an invalid or taken port. 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval portWin { 12 | # Widgets that are used througout this module for updating 13 | # messages and for setting and retrieving port values. 14 | 15 | variable msgLbl 16 | variable portEnt 17 | 18 | # Vwait variable used to indicate when a valid port has been 19 | # entered. 20 | 21 | variable newPortVar 22 | } 23 | 24 | # portWin::showWindow -- 25 | # 26 | # Show the window. If it does not exist, create it. If it does 27 | # exist, bring it to focus. 28 | # 29 | # Arguments: 30 | # port The invalid port. 31 | # 32 | # Results: 33 | # The next OK port to use. 34 | 35 | proc portWin::showWindow {port} { 36 | if {[info command $gui::gui(errorPortWin)] == $gui::gui(errorPortWin)} { 37 | wm deiconify $gui::gui(errorPortWin) 38 | } else { 39 | portWin::CreateWindow 40 | } 41 | 42 | portWin::UpdateWindow $port 43 | focus -force $portWin::portEnt 44 | grab $gui::gui(errorPortWin) 45 | 46 | vwait portWin::newPortVar 47 | return $portWin::newPortVar 48 | } 49 | 50 | # portWin::CreateWindow -- 51 | # 52 | # Create the window from scratch. It is assumed that the window 53 | # currently does not exist. 54 | # 55 | # Arguments: 56 | # None. 57 | # 58 | # Results: 59 | # None. 60 | 61 | proc portWin::CreateWindow {} { 62 | variable msgLbl 63 | variable portEnt 64 | 65 | set bd 2 66 | set pad 6 67 | set pad2 3 68 | set width 350 69 | set height 50 70 | 71 | set top [toplevel $gui::gui(errorPortWin)] 72 | wm title $top "Error Opening Port" 73 | wm minsize $top 100 100 74 | wm transient $top $gui::gui(mainDbgWin) 75 | 76 | # Center window on the screen. 77 | 78 | set w [winfo screenwidth .] 79 | set h [winfo screenheight .] 80 | wm geometry $gui::gui(errorPortWin) \ 81 | +[expr {($w/2) - ($width/2)}]+[expr {($h/2) - ($height/2)}] 82 | 83 | set mainFrm [frame $top.mainFrm -bd $bd -relief raised] 84 | set imageLbl [label $mainFrm.imageLbl -bitmap error] 85 | set msgLbl [label $mainFrm.msgLbl -wraplength $width -justify left] 86 | 87 | set portFrm [frame $mainFrm.portFrm] 88 | set portLabel [label $portFrm.portLabel -text "Next available port:"] 89 | set portEnt [entry $portFrm.portEnt -width 6 -exportselection 0] 90 | 91 | set butFrm [frame $top.butFrm] 92 | set okBut [button $butFrm.okBut -text "OK" -default active \ 93 | -command {portWin::ApplyWindow} -width 12] 94 | set cancelBut [button $butFrm.cancelBut -text "Cancel" -default normal \ 95 | -command [list destroy $top] -width 12] 96 | 97 | pack $portEnt -side right 98 | pack $portLabel -side right 99 | 100 | grid $imageLbl -row 0 -column 0 -sticky w -padx $pad -pady $pad 101 | grid $msgLbl -row 0 -column 1 -sticky w -padx $pad -pady $pad 102 | grid $portFrm -row 2 -column 1 -sticky w -padx $pad -pady $pad 103 | grid columnconfigure $mainFrm 1 -weight 1 104 | grid rowconfigure $mainFrm 1 -weight 1 105 | 106 | pack $cancelBut -side right -padx $pad 107 | pack $okBut -side right -padx $pad 108 | pack $butFrm -side bottom -fill x -pady $pad2 109 | pack $mainFrm -side bottom -fill both -expand true -padx $pad -pady $pad 110 | 111 | bind $portEnt "$okBut invoke; break" 112 | bind $okBut {%W invoke; break} 113 | bind $top "$okBut invoke; break" 114 | bind $top "$cancelBut invoke; break" 115 | 116 | return 117 | } 118 | 119 | # portWin::UpdateWindow -- 120 | # 121 | # Show the error message and prompt the user for a new port. 122 | # 123 | # Arguments: 124 | # port The invalid port. 125 | # 126 | # Results: 127 | # None. 128 | 129 | proc portWin::UpdateWindow {port} { 130 | variable msgLbl 131 | variable portEnt 132 | 133 | # Insert the message stating that the port was taken or is invalid. 134 | 135 | append msg "Port \"$port\" is invalid or in use. " 136 | append msg "Please specify another port to use for this project. " 137 | append msg "This will automatically modify your project settings." 138 | $msgLbl configure -text $msg 139 | 140 | # Find the next open port. Loop while the port is in use. 141 | # Make sure the port entered is a valid integer. If it is not, use 142 | # the initial factory default setting as a starting point for locating 143 | # the next available port. 144 | 145 | if {[catch {incr port}]} { 146 | set port [pref::prefGet portRemote ProjectFactory] 147 | } 148 | while {![portWin::isPortValid $port]} { 149 | incr port 150 | } 151 | 152 | # Insert the new suggested port to be used. 153 | 154 | $portEnt delete 0 end 155 | $portEnt insert 0 $port 156 | $portEnt selection range 0 end 157 | 158 | return 159 | } 160 | 161 | # portWin::ApplyWindow -- 162 | # 163 | # Verify the new port is valid. If the nerw port is valid then 164 | # destroy the window and set the vwait var to the value of the 165 | # port. Otherwise beep and update the error message. 166 | # 167 | # Arguments: 168 | # None. 169 | # 170 | # Results: 171 | # None. 172 | 173 | proc portWin::ApplyWindow {} { 174 | variable portEnt 175 | 176 | set port [$portEnt get] 177 | if {[portWin::isPortValid $port]} { 178 | grab release $gui::gui(errorPortWin) 179 | destroy $gui::gui(errorPortWin) 180 | set ::portWin::newPortVar $port 181 | } else { 182 | bell 183 | portWin::UpdateWindow $port 184 | } 185 | return 186 | } 187 | 188 | # portWin::isPortValid -- 189 | # 190 | # Test to see if the port is valid. 191 | # 192 | # Arguments: 193 | # port The port to test. 194 | # 195 | # Results: 196 | # Return a boolean, 1 means the port is OK. 197 | 198 | proc portWin::isPortValid {port} { 199 | global errorCode 200 | 201 | # First test to see that the port is a valid integer. 202 | 203 | if {[catch {incr port 0}]} { 204 | return 0 205 | } 206 | 207 | # If the errorCode is not EADDRINUSE nor EACCES then an error occured 208 | # that was not a taken port. Make sure to close the port when one 209 | # is found, so the correct routine can be called to re-open 210 | # the same port. 211 | 212 | if {([catch {set sock [socket -server dummy $port]}] != 0) \ 213 | && ([lsearch -exact \ 214 | [list "EADDRINUSE" "EACCES"] \ 215 | [lindex $errorCode 1]] != -1)} { 216 | return 0 217 | } 218 | close $sock 219 | return 1 220 | } 221 | 222 | -------------------------------------------------------------------------------- /lib/tcldebugger/varWin.tcl: -------------------------------------------------------------------------------- 1 | # varWin.tcl -- 2 | # 3 | # This file implements the Var Window (contained in the 4 | # main debugger window.) 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | 12 | namespace eval var { 13 | # Handles to the text windows that display variable names 14 | # and values. 15 | 16 | variable valuText {} 17 | variable nameText {} 18 | variable vbpText {} 19 | } 20 | 21 | # var::createWindow -- 22 | # 23 | # Create the var window and all of the sub elements. 24 | # 25 | # Arguments: 26 | # masterFrm The frame that contains the var frame. 27 | # 28 | # Results: 29 | # The frame that contains the Var Window. 30 | 31 | proc var::createWindow {masterFrm} { 32 | variable nameText 33 | variable valuText 34 | variable vbpText 35 | 36 | array set bar [system::getBar] 37 | 38 | set varFrm [frame $masterFrm.varFrm] 39 | set nameFrm [frame $varFrm.nameFrm] 40 | set vbpFrm [frame $nameFrm.vbpFrm -width $bar(width)] 41 | set vbpText [text $vbpFrm.vbpTxt -width 1 -height 20 -bd 0 \ 42 | -bg $bar(color)] 43 | set nameText [text $nameFrm.nameTxt -width 20 -height 20 -bd 0] 44 | set valuFrm [frame $varFrm.valuFrm] 45 | set valuText [text $valuFrm.valuTxt -width 20 -height 20 -bd 0 \ 46 | -yscroll [list $valuFrm.sb set]] 47 | set sb [scrollbar $valuFrm.sb -command {watch::scrollWindow \ 48 | $var::nameText}] 49 | 50 | pack propagate $vbpFrm 0 51 | pack $vbpFrm -side left -fill y 52 | pack $vbpText -side left -fill both -expand true 53 | pack $nameText -side left -fill both -expand true 54 | grid $valuText -sticky wnse -row 0 -column 0 55 | grid columnconfigure $valuFrm 0 -weight 1 56 | grid rowconfigure $valuFrm 0 -weight 1 57 | guiUtil::tableCreate $varFrm $nameFrm $valuFrm \ 58 | -title1 "Variable" -title2 "Value" -percent 0.4 59 | 60 | # Create the mapping for Watch text widgets. See the 61 | # description of the text variable in the namespace eval 62 | # statement of watchWin.tcl. 63 | 64 | set watch::text(name,$nameText) $nameText 65 | set watch::text(name,$valuText) $nameText 66 | set watch::text(name,$vbpText) $nameText 67 | set watch::text(valu,$nameText) $valuText 68 | set watch::text(valu,$valuText) $valuText 69 | set watch::text(valu,$vbpText) $valuText 70 | set watch::text(vbp,$nameText) $vbpText 71 | set watch::text(vbp,$valuText) $vbpText 72 | set watch::text(vbp,$vbpText) $vbpText 73 | 74 | bind::addBindTags $valuText [list watchBind varDbgWin] 75 | bind::addBindTags $nameText [list watchBind varDbgWin] 76 | watch::internalBindings $nameText $valuText $vbpText $sb 77 | gui::registerStatusMessage $vbpText \ 78 | "Click in the bar to set a variable breakpoint" 79 | sel::setWidgetCmd $valuText all { 80 | watch::cleanupSelection $var::valuText 81 | var::checkState 82 | } { 83 | watch::seeCallback $var::valuText 84 | } 85 | 86 | bind varDbgWin <> { 87 | var::addToWatch 88 | } 89 | $valuText tag bind handle { 90 | set gui::afterStatus(%W) [after 2000 \ 91 | {gui::updateStatusMessage -msg \ 92 | "Click to expand or flatten the array"}] 93 | } 94 | $valuText tag bind handle { 95 | if {[info exists gui::afterStatus(%W)]} { 96 | after cancel $gui::afterStatus(%W) 97 | unset gui::afterStatus(%W) 98 | gui::updateStatusMessage -msg {} 99 | } 100 | } 101 | 102 | return $varFrm 103 | } 104 | 105 | # var::updateWindow -- 106 | # 107 | # Update the display of the Var window. This routine 108 | # expects the return of gui::getCurrentLevel to give 109 | # the level displayed in the Stack Window. 110 | # 111 | # Arguments: 112 | # None. 113 | # 114 | # Results: 115 | # None. 116 | 117 | proc var::updateWindow {} { 118 | variable nameText 119 | variable valuText 120 | variable vbpText 121 | 122 | if {[gui::getCurrentState] != "stopped"} { 123 | return 124 | } 125 | 126 | set level [gui::getCurrentLevel] 127 | set varList [lsort -dictionary -index 1 \ 128 | [watch::varDataAddVars $valuText $level]] 129 | 130 | # Call the internal routine that populates the var name and 131 | # var value windows. 132 | 133 | watch::updateInternal $nameText $valuText $vbpText $varList $level 134 | } 135 | 136 | # var::resetWindow -- 137 | # 138 | # Clear the contents of the window and display a 139 | # message in its place. 140 | # 141 | # Arguments: 142 | # msg If not null, then display the contents of the 143 | # message in the window. 144 | # 145 | # Results: 146 | # None. 147 | 148 | proc var::resetWindow {{msg {}}} { 149 | variable nameText 150 | variable valuText 151 | variable vbpText 152 | 153 | gui::unsetFormatData $nameText 154 | gui::unsetFormatData $valuText 155 | $nameText delete 0.0 end 156 | $valuText delete 0.0 end 157 | $vbpText delete 0.0 end 158 | 159 | if {$msg != {}} { 160 | $valuText insert 0.0 $msg message 161 | } 162 | } 163 | 164 | # var::checkState -- 165 | # 166 | # This proc is executed whenever the selection 167 | # in the Var Window changes. 168 | # 169 | # Arguments: 170 | # None. 171 | # 172 | # Results: 173 | # None. 174 | 175 | proc var::checkState {} { 176 | variable valuText 177 | 178 | if {[focus] == $valuText} { 179 | watch::changeFocus $valuText in 180 | } 181 | } 182 | 183 | # watch::addToWatch -- 184 | # 185 | # Add the selected variables to the Watch Window. 186 | # 187 | # Arguments: 188 | # None. 189 | # 190 | # Results: 191 | # None. 192 | 193 | proc var::addToWatch {} { 194 | variable valuText 195 | 196 | set lineList [sel::getSelectedLines $valuText] 197 | foreach line $lineList { 198 | set oname [watch::varDataGet $valuText $line.0 "oname"] 199 | watch::addVar $oname 200 | } 201 | } 202 | 203 | # var::seeVarInWindow -- 204 | # 205 | # Move the Var Window to show the variable that was selected 206 | # in the Stack Window. The Var Window is assumed to be updated 207 | # to the current frame and that the variable exists in the 208 | # frame. 209 | # 210 | # Arguments: 211 | # varName The name of the variable to be moved into 212 | # sight of the var window. 213 | # moveFocus Boolean value, if true move the focus to the 214 | # Var Window after the word is shown. 215 | # 216 | # Results: 217 | # None. 218 | 219 | proc var::seeVarInWindow {varName moveFocus} { 220 | variable nameText 221 | variable valuText 222 | 223 | # Build a list of line numbers, one foreach line in the 224 | # Var Window. The pass this to watch::getVarNames to 225 | # retrieve a list of all valid var names. 226 | 227 | set varNameList {} 228 | for {set i 1} {$i < [$var::nameText index end]} {incr i} { 229 | set oname [watch::varDataGet $valuText $i.0 "oname"] 230 | lappend varNameList [code::mangle $oname] 231 | } 232 | 233 | # Search the list of var names to see if the var exists in the 234 | # Var Window. If so select the line and possibly force the 235 | # focus to the Var WIndow. 236 | 237 | set line [expr {[lsearch $varNameList $varName] + 1}] 238 | if {$line >= 0} { 239 | watch::selectLine $nameText $line.0 240 | if {$moveFocus} { 241 | focus $valuText 242 | } 243 | } 244 | } 245 | -------------------------------------------------------------------------------- /lib/tcldebugger/break.tcl: -------------------------------------------------------------------------------- 1 | # break.tcl -- 2 | # 3 | # This file implements the breakpoint object API. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | package provide break 1.0 11 | namespace eval break { 12 | # breakpoint data type -- 13 | # 14 | # A breakpoint object encapsulates the state associated with a 15 | # breakpoint. Each breakpoint is represented by a Tcl array 16 | # whose name is of the form break where is 17 | # L for line-based breakpoints and V for variable breakpoints. 18 | # Each array contains the following elements: 19 | # state Either enabled or disabled. 20 | # test The script in conditional breakpoints. 21 | # location The location or trace handle for the 22 | # breakpoint. 23 | # data This field holds arbitrary data associated 24 | # with the breakpoint for use by the GUI. 25 | # 26 | # Fields: 27 | # counter This counter is used to generate breakpoint names. 28 | 29 | variable counter 0 30 | } 31 | # end namespace break 32 | 33 | # break::MakeBreakpoint -- 34 | # 35 | # Create a new breakpoint. 36 | # 37 | # Arguments: 38 | # type One of "line" or "var" 39 | # where Location for line breakpoints; trace handle for 40 | # variable breakpoints. 41 | # test Optional. Script to use for conditional breakpoint. 42 | # 43 | # Results: 44 | # Returns a breakpoint identifier. 45 | 46 | proc break::MakeBreakpoint {type location {test {}}} { 47 | variable counter 48 | 49 | if {$type == "line"} { 50 | set type L 51 | } else { 52 | set type V 53 | } 54 | 55 | # find an unallocated breakpointer number and create the array 56 | 57 | incr counter 58 | while {[info exists ::break::break$type$counter]} { 59 | incr counter 60 | } 61 | set name $type$counter 62 | array set ::break::break$name \ 63 | [list data {} location $location state enabled test $test] 64 | return $name 65 | } 66 | 67 | # break::Release -- 68 | # 69 | # Release the storage associated with one or more breakpoints. 70 | # 71 | # Arguments: 72 | # breakList The breakpoints to release, or "all". 73 | # 74 | # Results: 75 | # None. 76 | 77 | proc break::Release {breakList} { 78 | if {$breakList == "all"} { 79 | # Release all breakpoints 80 | set all [info vars ::break::break*] 81 | if {$all != ""} { 82 | eval unset $all 83 | } 84 | } else { 85 | foreach breakpoint $breakList { 86 | if {[info exist ::break::break$breakpoint]} { 87 | unset ::break::break$breakpoint 88 | } 89 | } 90 | } 91 | return 92 | } 93 | 94 | # break::getState -- 95 | # 96 | # Return the breakpoint state. 97 | # 98 | # Arguments: 99 | # breakpoint The breakpoint identifier. 100 | # 101 | # Results: 102 | # Returns one of enabled or disabled. 103 | 104 | proc break::getState {breakpoint} { 105 | return [set ::break::break${breakpoint}(state)] 106 | } 107 | 108 | # break::getLocation -- 109 | # 110 | # Return the breakpoint location. 111 | # 112 | # Arguments: 113 | # breakpoint The breakpoint identifier. 114 | # 115 | # Results: 116 | # Returns the breakpoint location. 117 | 118 | proc break::getLocation {breakpoint} { 119 | return [set ::break::break${breakpoint}(location)] 120 | } 121 | 122 | 123 | # break::getTest -- 124 | # 125 | # Return the breakpoint test. 126 | # 127 | # Arguments: 128 | # breakpoint The breakpoint identifier. 129 | # 130 | # Results: 131 | # Returns the breakpoint test. 132 | 133 | proc break::getTest {breakpoint} { 134 | return [set ::break::break${breakpoint}(test)] 135 | } 136 | 137 | # break::getType -- 138 | # 139 | # Return the type of the breakpoint. 140 | # 141 | # Arguments: 142 | # breakpoint The breakpoint identifier. 143 | # 144 | # Results: 145 | # Returns the breakpoint type; one of "line" or "var". 146 | 147 | proc break::getType {breakpoint} { 148 | switch [string index $breakpoint 0] { 149 | V { 150 | return "var" 151 | } 152 | L { 153 | return "line" 154 | } 155 | } 156 | error "Invalid breakpoint type" 157 | } 158 | 159 | 160 | # break::SetState -- 161 | # 162 | # Change the breakpoint state. 163 | # 164 | # Arguments: 165 | # breakpoint The breakpoint identifier. 166 | # state One of enabled or disabled. 167 | # 168 | # Results: 169 | # None. 170 | 171 | proc break::SetState {breakpoint state} { 172 | set ::break::break${breakpoint}(state) $state 173 | return 174 | } 175 | 176 | # break::getData -- 177 | # 178 | # Retrieve the client data field. 179 | # 180 | # Arguments: 181 | # breakpoint The breakpoint identifier. 182 | # 183 | # Results: 184 | # Returns the data field. 185 | 186 | proc break::getData {breakpoint} { 187 | return [set ::break::break${breakpoint}(data)] 188 | } 189 | 190 | # break::setData -- 191 | # 192 | # Set the client data field. 193 | # 194 | # Arguments: 195 | # breakpoint The breakpoint identifier. 196 | # 197 | # Results: 198 | # None. 199 | 200 | proc break::setData {breakpoint data} { 201 | set ::break::break${breakpoint}(data) $data 202 | return 203 | } 204 | 205 | # break::GetLineBreakpoints -- 206 | # 207 | # Returns a list of all line-based breakpoint indentifiers. If the 208 | # optional location is specified, only breakpoints set at that 209 | # location are returned. 210 | # 211 | # Arguments: 212 | # location Optional. The location of the breakpoint to get. 213 | # 214 | # Results: 215 | # Returns a list of all line-based breakpoint indentifiers. 216 | 217 | proc break::GetLineBreakpoints {{location {}}} { 218 | set result {} 219 | foreach breakpoint [info vars ::break::breakL*] { 220 | if {($location == "") \ 221 | || [loc::match $location [set ${breakpoint}(location)]]} { 222 | lappend result $breakpoint 223 | } 224 | } 225 | 226 | regsub -all {::break::break} $result {} result 227 | return $result 228 | } 229 | 230 | # break::GetVarBreakpoints -- 231 | # 232 | # Returns a list of all variable-based breakpoint indentifiers 233 | # for a specified variable trace. 234 | # 235 | # Arguments: 236 | # handle The trace handle. 237 | # 238 | # Results: 239 | # A list of breakpoint identifiers. 240 | 241 | proc break::GetVarBreakpoints {{handle {}}} { 242 | set result {} 243 | foreach breakpoint [info vars ::break::breakV*] { 244 | if {($handle == "") \ 245 | || ([set ${breakpoint}(location)] == $handle)} { 246 | lappend result $breakpoint 247 | } 248 | } 249 | regsub -all {::break::break} $result {} result 250 | return $result 251 | } 252 | 253 | # break::preserveBreakpoints -- 254 | # 255 | # Generate a persistent representation for all line-based 256 | # breakpoints so they can be stored in the user preferences. 257 | # 258 | # Arguments: 259 | # varName Name of variable where breakpoint info should 260 | # be stored. 261 | # 262 | # Results: 263 | # None. 264 | 265 | proc break::preserveBreakpoints {varName} { 266 | upvar $varName data 267 | set data {} 268 | foreach bp [GetLineBreakpoints] { 269 | set location [getLocation $bp] 270 | set file [blk::getFile [loc::getBlock $location]] 271 | set line [loc::getLine $location] 272 | if {$file != ""} { 273 | lappend data [list $file $line [getState $bp] \ 274 | [getTest $bp]] 275 | } 276 | } 277 | return 278 | } 279 | 280 | # break::restoreBreakpoints -- 281 | # 282 | # Recreate a set of breakpoints from a previously preserved list. 283 | # 284 | # Arguments: 285 | # data The data generated by a previous call to 286 | # preserveBreakpoints. 287 | # 288 | # Results: 289 | # None. 290 | 291 | proc break::restoreBreakpoints {data} { 292 | foreach bp $data { 293 | set block [blk::makeBlock [lindex $bp 0]] 294 | set location [loc::makeLocation $block [lindex $bp 1]] 295 | SetState [MakeBreakpoint "line" $location [lindex $bp 3]] \ 296 | [lindex $bp 2] 297 | } 298 | return 299 | } 300 | -------------------------------------------------------------------------------- /lib/tcldebugger/tests/block.test: -------------------------------------------------------------------------------- 1 | # This file contains tests for the block.tcl file. 2 | # 3 | # Copyright (c) 1998-2000 by Ajuba Solutions 4 | # Copyright (c) 2017 Forward Folio LLC 5 | # 6 | # See the file "license.terms" for information on usage and redistribution 7 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8 | # 9 | 10 | if {[string compare test [info procs test]] == 1} { 11 | lappend auto_path [file join [file dirname [info script]] ..] 12 | package require protest 13 | namespace import ::protest::* 14 | } 15 | 16 | catch {parse} parseMsg 17 | if {[regexp "invalid command" $parseMsg]} { 18 | package require parser 19 | } 20 | 21 | source [file join $::protest::sourceDirectory system.tcl] 22 | source [file join $::protest::sourceDirectory block.tcl] 23 | source [file join $::protest::sourceDirectory instrument.tcl] 24 | source [file join $::protest::sourceDirectory location.tcl] 25 | source [file join $::protest::sourceDirectory util.tcl] 26 | 27 | set pwd [pwd] 28 | cd $::tcltest::temporaryDirectory 29 | 30 | set contents "line 1\nline2\nline3\n" 31 | makeFile $contents dummy.tcl 32 | 33 | blk::release all 34 | 35 | test block-1.1 {blk::makeBlock, duplicates} { 36 | set b1 [blk::makeBlock dummy.tcl] 37 | set b2 [blk::makeBlock dummy.tcl] 38 | set result [list [string compare $b1 $b2] \ 39 | [lsort [array names blk::blk$b1]] \ 40 | [set blk::blk${b1}(file)] [set blk::blk${b1}(instrumented)] \ 41 | [set blk::blk${b1}(version)]] 42 | 43 | blk::release $b1 44 | set result 45 | } {0 {file instrumented lines version} dummy.tcl 0 0} 46 | test block-1.2 {blk::makeBlock, multiple} { 47 | set b1 [blk::makeBlock dummy.tcl] 48 | set b2 [blk::makeBlock dummy2.tcl] 49 | set result [list [expr [string compare $b1 $b2] == 0] \ 50 | [lsort [array names blk::blk$b1]] \ 51 | [set blk::blk${b1}(file)] [set blk::blk${b1}(instrumented)] \ 52 | [set blk::blk${b1}(version)] \ 53 | [lsort [array names blk::blk$b2]] \ 54 | [set blk::blk${b2}(file)] [set blk::blk${b2}(instrumented)] \ 55 | [set blk::blk${b2}(version)]] 56 | blk::release $b1 $b2 57 | set result 58 | } {0 {file instrumented lines version} dummy.tcl 0 0 {file instrumented lines version} dummy2.tcl 0 0} 59 | test block-1.3 {blk::makeBlock, id reuse} { 60 | set next [expr $blk::blockCounter + 1] 61 | set blk::blk$next 1 62 | set b1 [blk::makeBlock dummy.tcl] 63 | set result [expr $b1 == $next] 64 | blk::release $b1 65 | set result 66 | } 0 67 | test block-1.4 {blk::makeBlock, dynamic blocks} { 68 | set b1 [blk::makeBlock ""] 69 | set b2 [blk::makeBlock ""] 70 | set result [expr [string compare $b1 $b2] == 0] 71 | blk::release $b1 $b2 72 | set result 73 | } 0 74 | 75 | test block-2.1 {blk::release, single} { 76 | set b1 [blk::makeBlock ""] 77 | set result [info exists blk::blk$b1] 78 | blk::release $b1 79 | lappend result [info exists blk::blk$b1] 80 | } {1 0} 81 | test block-2.2 {blk::release, multiple} { 82 | set b1 [blk::makeBlock ""] 83 | set b2 [blk::makeBlock ""] 84 | set result [list [info exists blk::blk$b1] [info exists blk::blk$b2]] 85 | blk::release $b1 $b2 86 | lappend result [info exists blk::blk$b1] [info exists blk::blk$b2] 87 | } {1 1 0 0} 88 | test block-2.3 {blk::release, bad input} { 89 | list [info exists blk::blk1] [blk::release 1] 90 | } {0 {}} 91 | 92 | test block-4.1 {blk::exists} { 93 | blk::release 1 94 | blk::exists 1 95 | } 0 96 | test block-4.2 {blk::exists} { 97 | set b1 [blk::makeBlock foo] 98 | set result [blk::exists $b1] 99 | blk::release $b1 100 | set result 101 | } 1 102 | 103 | test block-3.1 {blk::getSource, instrumented} { 104 | set b1 [blk::makeBlock foo] 105 | blk::Instrument $b1 foobarbaz 106 | set result [blk::getSource $b1] 107 | blk::release $b1 108 | set result 109 | } foobarbaz 110 | test block-3.2 {blk::getSource, uninstrumented} { 111 | set b1 [blk::makeBlock dummy.tcl] 112 | set result [string compare [blk::getSource $b1] $contents] 113 | blk::release $b1 114 | set result 115 | } 0 116 | test block-3.3 {blk::getSource, partially constructed dynamic code} { 117 | set b1 [blk::makeBlock ""] 118 | set result [list [blk::getSource $b1]] 119 | blk::Instrument $b1 foobarbaz 120 | lappend result [blk::getSource $b1] 121 | blk::release $b1 122 | set result 123 | } {{} foobarbaz} 124 | test block-3.4 {blk::getSource, multiple reads from file} { 125 | set b1 [blk::makeBlock dummy.tcl] 126 | set result [string compare [blk::getSource $b1] $contents] 127 | lappend result [blk::getVersion $b1] 128 | lappend result [string compare [blk::getSource $b1] $contents] 129 | lappend result [blk::getVersion $b1] 130 | blk::release $b1 131 | set result 132 | } {0 1 0 2} 133 | 134 | test block-4.1 {blk::getFile} { 135 | set b1 [blk::makeBlock foobar] 136 | set result [blk::getFile $b1] 137 | blk::release $b1 138 | set result 139 | } foobar 140 | test block-4.2 {blk::getFile} { 141 | set b1 [blk::makeBlock ""] 142 | set result [blk::getFile $b1] 143 | blk::release $b1 144 | set result 145 | } {} 146 | 147 | set b1 [blk::makeBlock foobar] 148 | test block-5.1 {blk::Instrument} { 149 | blk::Instrument $b1 blah 150 | } "DbgNub_Do 0 {$b1 1 {0 4}} blah" 151 | blk::release $b1 152 | 153 | test block-6.1 {blk::isInstrumented} { 154 | set b1 [blk::makeBlock ""] 155 | blk::Instrument $b1 blah 156 | set result [blk::isInstrumented $b1] 157 | blk::release $b1 158 | set result 159 | } 1 160 | test block-6.2 {blk::isInstrumented} { 161 | set b1 [blk::makeBlock ""] 162 | set result [blk::isInstrumented $b1] 163 | blk::release $b1 164 | set result 165 | } 0 166 | 167 | test block-7.1 {blk::getVersion} { 168 | set b1 [blk::makeBlock dummy.tcl] 169 | set result [blk::getVersion $b1] 170 | blk::getSource $b1 171 | lappend result [blk::getVersion $b1] 172 | blk::getSource $b1 173 | lappend result [blk::getVersion $b1] 174 | blk::Instrument $b1 blah 175 | lappend result [blk::getVersion $b1] 176 | blk::getSource $b1 177 | lappend result [blk::getVersion $b1] 178 | blk::Instrument $b1 blah 179 | lappend result [blk::getVersion $b1] 180 | blk::release $b1 181 | set result 182 | } {0 1 2 3 3 4} 183 | 184 | test block-8.1 {blk::getFiles} { 185 | blk::getFiles 186 | } {} 187 | test block-8.2 {blk::getFiles} { 188 | set b1 [blk::makeBlock dummy.tcl] 189 | set result [blk::getFiles] 190 | blk::release $b1 191 | string compare $b1 $result 192 | } 0 193 | test block-8.3 {blk::getFiles} { 194 | set b1 [blk::makeBlock dummy.tcl] 195 | set b2 [blk::makeBlock ""] 196 | set result [blk::getFiles] 197 | blk::release $b1 $b2 198 | string compare $b1 $result 199 | } 0 200 | test block-8.3 {blk::getFiles} { 201 | set b1 [blk::makeBlock dummy.tcl] 202 | set b2 [blk::makeBlock foo] 203 | set result [lsort -integer [blk::getFiles]] 204 | blk::release $b1 $b2 205 | string compare [list $b1 $b2] $result 206 | } 0 207 | test block-8.4 {blk::getFiles} { 208 | set b1 [blk::makeBlock ""] 209 | set b2 [blk::makeBlock ""] 210 | set result [lsort -integer [blk::getFiles]] 211 | blk::release $b1 $b2 212 | string compare "" $result 213 | } 0 214 | 215 | test block-9.1 {blk::SetSource} { 216 | blk::getSource Temp 217 | } {} 218 | test block-9.2 {blk::SetTemp} { 219 | blk::SetSource Temp foobar 220 | blk::getSource Temp 221 | } foobar 222 | test block-9.3 {blk::SetTemp} { 223 | set v [blk::getVersion Temp] 224 | blk::SetSource Temp foobar 225 | expr [blk::getVersion Temp] - $v 226 | } 1 227 | 228 | # blk::setSource has already been tested thoroughly by the previous tests 229 | 230 | file delete dummy.tcl 231 | blk::release all 232 | cd $pwd 233 | cleanupTests 234 | if {[info exists tk_version] && !$tcl_interactive} { 235 | exit 236 | } 237 | -------------------------------------------------------------------------------- /lib/tcldebugger/toolbar.tcl: -------------------------------------------------------------------------------- 1 | # toolbar.tcl -- 2 | # 3 | # This file implements the Tcl Debugger toolbar. 4 | # 5 | # Copyright (c) 1998-2000 Ajuba Solutions 6 | # Copyright (c) 2017 Forward Folio LLC 7 | # See the file "license.terms" for information on usage and redistribution of this file. 8 | # 9 | 10 | namespace eval tool { 11 | # Array used to store handles to all of the toolbar buttons. 12 | 13 | variable tool 14 | 15 | # Store the top frame of the toolbar. 16 | 17 | variable toolbarFrm 18 | } 19 | 20 | # tool::createWindow -- 21 | # 22 | # Load the button images, create the buttons and add the callbacks. 23 | # 24 | # Arguments: 25 | # mainDbgWin The toplevel window for the main debugger. 26 | # 27 | # Results: 28 | # The handle to the frame that contains all of the toolbar buttons. 29 | 30 | proc tool::createWindow {mainDbgWin} { 31 | variable tool 32 | variable toolbarFrm 33 | 34 | set toolbarFrm [frame $mainDbgWin.tool -bd 2 -relief groove] 35 | 36 | set tool(run) [tool::createButton $toolbarFrm.runButt $image::image(run) \ 37 | {Run until break or EOF.} \ 38 | {gui::run dbg::run}] 39 | set tool(into) [tool::createButton $toolbarFrm.intoButt $image::image(into) \ 40 | {Step into the next procedure.} \ 41 | {gui::run dbg::step}] 42 | set tool(over) [tool::createButton $toolbarFrm.overButt $image::image(over) \ 43 | {Step over the next procedure.} \ 44 | {gui::run {dbg::step over}}] 45 | set tool(out) [tool::createButton $toolbarFrm.outButt $image::image(out) \ 46 | {Step out of the current procedure.} \ 47 | {gui::run {dbg::step out}}] 48 | set tool(to) [tool::createButton $toolbarFrm.toButt $image::image(to) \ 49 | {Run to cursor.} \ 50 | {gui::runTo}] 51 | set tool(cmdresult) [tool::createButton $toolbarFrm.cmdresultButt \ 52 | $image::image(cmdresult) \ 53 | {Step to result of current command.} \ 54 | {gui::run {dbg::step cmdresult}}] 55 | pack [frame $toolbarFrm.sep1 -bd 4 -relief groove -width 2] \ 56 | -pady 2 -fill y -side left 57 | set tool(stop) [tool::createButton $toolbarFrm.stopButt $image::image(stop) \ 58 | {Stop at the next instrumented statement.} \ 59 | {gui::interrupt}] 60 | set tool(kill) [tool::createButton $toolbarFrm.killButt $image::image(kill) \ 61 | {Kill the current application.} \ 62 | {gui::kill}] 63 | set tool(restart) [tool::createButton $toolbarFrm.restartButt \ 64 | $image::image(restart) \ 65 | {Restart the application.} \ 66 | {proj::restartProj}] 67 | pack [frame $toolbarFrm.sep2 -bd 4 -relief groove -width 2] \ 68 | -pady 2 -fill y -side left 69 | set tool(refreshFile) [tool::createButton $toolbarFrm.refreshFileButt \ 70 | $image::image(refreshFile) \ 71 | {Refresh the current file.} \ 72 | {menu::refreshFile}] 73 | 74 | pack [frame $toolbarFrm.sep3 -bd 4 -relief groove -width 2] \ 75 | -pady 2 -fill y -side left 76 | set tool(win_break) [tool::createButton $toolbarFrm.win_breakButt \ 77 | $image::image(win_break) \ 78 | {Display the Breakpoint Window.} \ 79 | {bp::showWindow}] 80 | set tool(win_eval) [tool::createButton $toolbarFrm.win_evalButt \ 81 | $image::image(win_eval) \ 82 | {Display the Eval Console Window.} \ 83 | {evalWin::showWindow}] 84 | set tool(win_proc) [tool::createButton $toolbarFrm.win_procButt \ 85 | $image::image(win_proc) \ 86 | {Display the Procedure Window.} \ 87 | {procWin::showWindow}] 88 | set tool(win_watch) [tool::createButton $toolbarFrm.win_watchButt \ 89 | $image::image(win_watch) \ 90 | {Display the Watch Variables Window.} \ 91 | {watch::showWindow}] 92 | 93 | return $toolbarFrm 94 | } 95 | 96 | # tool::addButton -- 97 | # 98 | # Append a new button at the end of the toolbar. 99 | # 100 | # Arguments: 101 | # name The name of the button to create. 102 | # img An image that has already beeen created. 103 | # txt Text to display in the help window. 104 | # cmd Command to execute when pressed. 105 | # 106 | # Results: 107 | # Returns the widget name for the button. 108 | 109 | proc tool::addButton {name img txt cmd} { 110 | variable tool 111 | variable toolbarFrm 112 | 113 | set tool($name) [tool::createButton $toolbarFrm.$name $img \ 114 | $txt $cmd] 115 | return $tool($name) 116 | } 117 | 118 | # tool::createButton -- 119 | # 120 | # Create uniform toolbar buttons and add bindings. 121 | # 122 | # Arguments: 123 | # but The name of the button to create. 124 | # img An image that has already beeen created. 125 | # txt Text to display in the help window. 126 | # cmd Command to execute when pressed. 127 | # side The default is to add the on the left side of the 128 | # toolbar - you may pass right to pack from the other 129 | # side. 130 | # 131 | # Results: 132 | # The name of the button being created. 133 | 134 | proc tool::createButton {but img txt cmd {side left}} { 135 | variable gui 136 | 137 | set but [button $but -image $img -command $cmd -relief flat \ 138 | -bd 1 -height [image height $img] -width [image width $img]] 139 | pack $but -side $side -pady 2 140 | 141 | gui::registerStatusMessage $but $txt 5 142 | tool::addButtonBindings $but 143 | 144 | return $but 145 | } 146 | 147 | # tool::addButtonBindings -- 148 | # 149 | # Add and bindings to the buttons so they raise and 150 | # lower as the mouse goes in and out of the button. This routine 151 | # should be called after the gui::registerStatusMessage to assure 152 | # the bindings are added in order. 153 | # 154 | # Arguments: 155 | # but The button to add the bindings to. 156 | # 157 | # Results: 158 | # None. 159 | 160 | proc tool::addButtonBindings {but} { 161 | bind $but {+ 162 | if {[%W cget -state] == "normal"} { 163 | %W config -relief raised 164 | } 165 | } 166 | bind $but {+ 167 | %W config -relief flat 168 | } 169 | } 170 | 171 | # tool::updateMessage -- 172 | # 173 | # Update the status message displayed based on the state of the debugger. 174 | # 175 | # Arguments: 176 | # state The new state of the debugger. 177 | # 178 | # Results: 179 | # None. 180 | 181 | proc tool::updateMessage {state} { 182 | variable tool 183 | 184 | # Override all of the and bindings and add the new 185 | # message to display for the help message. 186 | 187 | switch -exact -- $state { 188 | new - 189 | parseError - 190 | stopped - 191 | running { 192 | gui::registerStatusMessage $tool(run) \ 193 | {Run until break or EOF.} 5 194 | gui::registerStatusMessage $tool(into) \ 195 | {Step into the next procedure.} 5 196 | } 197 | dead { 198 | gui::registerStatusMessage $tool(run) \ 199 | {Start app and run until break or EOF.} 5 200 | gui::registerStatusMessage $tool(into) \ 201 | {Start app and step to first command.} 5 202 | } 203 | default { 204 | error "Unknown state \"$state\": in tool::updateMessage" 205 | } 206 | } 207 | 208 | # Now add the bindings that raise and lower the toolbar buttons. 209 | 210 | tool::addButtonBindings $tool(run) 211 | tool::addButtonBindings $tool(into) 212 | 213 | return 214 | } 215 | 216 | # tool::changeState -- 217 | # 218 | # Update the state of the Toolbar buttons. 219 | # 220 | # Arguments: 221 | # buttonList Names of the buttons to re-configure. 222 | # state The state all buttons in buttonList 223 | # will be configure to. 224 | # 225 | # Results: 226 | # None. 227 | 228 | proc tool::changeState {buttonList state} { 229 | variable tool 230 | 231 | foreach button $buttonList { 232 | switch $button { 233 | refreshFile - 234 | restart - 235 | run - 236 | stop - 237 | kill - 238 | inspector { 239 | $tool($button) configure -state $state 240 | tool::changeButtonState $button $state 241 | } 242 | stepIn { 243 | $tool(into) configure -state $state 244 | tool::changeButtonState into $state 245 | } 246 | stepOut { 247 | $tool(out) configure -state $state 248 | tool::changeButtonState out $state 249 | } 250 | stepOver { 251 | $tool(over) configure -state $state 252 | tool::changeButtonState over $state 253 | } 254 | stepTo { 255 | $tool(to) configure -state $state 256 | tool::changeButtonState to $state 257 | } 258 | stepResult { 259 | $tool(cmdresult) configure -state $state 260 | tool::changeButtonState cmdresult $state 261 | } 262 | showStack { 263 | $tool(stack) configure -state $state 264 | tool::changeButtonState stack $state 265 | } 266 | default { 267 | error "Unknown toolbar item \"$button\": in tool::changeState" 268 | } 269 | } 270 | } 271 | } 272 | 273 | # tool::changeButtonState -- 274 | # 275 | # Change the state of the button. 276 | # 277 | # Arguments: 278 | # but Name of the button. 279 | # state New state. 280 | # 281 | # Results: 282 | # None. 283 | 284 | proc tool::changeButtonState {but state} { 285 | variable tool 286 | 287 | if {$state == "disabled"} { 288 | $tool($but) configure -image $image::image(${but}_disable) 289 | } else { 290 | $tool($but) configure -image $image::image($but) 291 | } 292 | } 293 | 294 | 295 | -------------------------------------------------------------------------------- /lib/tcldebugger/evalWin.tcl: -------------------------------------------------------------------------------- 1 | # evalWin.tcl -- 2 | # 3 | # The file implements the Debuger interface to the 4 | # TkCon console (or whats left of it...) 5 | # 6 | # Copyright (c) 1998-2000 Ajuba Solutions 7 | # Copyright (c) 2017 Forward Folio LLC 8 | # See the file "license.terms" for information on usage and redistribution of this file. 9 | # 10 | 11 | namespace eval evalWin { 12 | 13 | # The handle to the text widget where commands are entered. 14 | 15 | variable evalText 16 | 17 | # The handle to the combo box that contains the list of 18 | # valid level to eval commands in. 19 | 20 | variable levelCombo 21 | 22 | # Used to delay UI changes do to state change. 23 | variable afterID 24 | } 25 | 26 | # evalWin::showWindow -- 27 | # 28 | # Show the Eval Window. If it already exists, just raise 29 | # it to the foreground. Otherwise, create a new eval window. 30 | # 31 | # Arguments: 32 | # None. 33 | # 34 | # Results: 35 | # The toplevel window name for the Eval Window. 36 | 37 | proc evalWin::showWindow {} { 38 | # If the window already exists, show it, otherwise 39 | # create it from scratch. 40 | 41 | if {[info command $gui::gui(evalDbgWin)] == $gui::gui(evalDbgWin)} { 42 | # evalWin::updateWindow 43 | wm deiconify $gui::gui(evalDbgWin) 44 | focus $evalWin::evalText 45 | return $gui::gui(evalDbgWin) 46 | } else { 47 | evalWin::createWindow 48 | evalWin::updateWindow 49 | focus $evalWin::evalText 50 | return $gui::gui(evalDbgWin) 51 | } 52 | } 53 | 54 | # evalWin::createWindow -- 55 | # 56 | # Create the Eval Window. 57 | # 58 | # Arguments: 59 | # None. 60 | # 61 | # Results: 62 | # None. 63 | 64 | proc evalWin::createWindow {} { 65 | variable evalText 66 | variable levelCombo 67 | 68 | set bd 2 69 | set pad 6 70 | 71 | set top [toplevel $gui::gui(evalDbgWin)] 72 | ::guiUtil::positionWindow $top 400x250 73 | wm protocol $top WM_DELETE_WINDOW "wm withdraw $top" 74 | wm minsize $top 100 100 75 | wm title $top "Eval Console" 76 | wm transient $top $gui::gui(mainDbgWin) 77 | 78 | # Create the level indicator and combo box. 79 | 80 | set mainFrm [frame $top.mainFrm -bd $bd -relief raised] 81 | set levelFrm [frame $mainFrm.levelFrm] 82 | set levelLbl [label $levelFrm.levelLbl -text "Stack Level:"] 83 | set levelCombo [guiUtil::ComboBox $levelFrm.levelCombo -ewidth 8 \ 84 | -textvariable gui::gui(evalLevelVar) -strict 1 \ 85 | -listheight 1 -listwidth 8 -listexportselection 0] 86 | set closeBut [button $levelFrm.closeBut -text "Close" -width 10 \ 87 | -command {destroy $gui::gui(evalDbgWin)}] 88 | pack $levelLbl -side left 89 | pack $levelCombo -side left -padx 3 90 | pack $closeBut -side right 91 | 92 | # Place a separating line between the var info and the 93 | # value of the var. 94 | 95 | set sepFrm [frame $mainFrm.sep1 -bd $bd -relief groove -height $bd] 96 | 97 | # Create the text widget that will be the eval console. 98 | 99 | set evalFrm [frame $mainFrm.evalFrm] 100 | set evalText [tkCon::InitUI $evalFrm Console] 101 | 102 | pack $levelFrm -fill x -padx $pad -pady $pad 103 | pack $sepFrm -fill x -padx $pad -pady $pad 104 | pack $evalFrm -fill both -expand true -padx $pad -pady $pad 105 | pack $mainFrm -fill both -expand true -padx $pad -pady $pad 106 | 107 | bind::addBindTags $evalText evalDbgWin 108 | bind::addBindTags $levelCombo evalDbgWin 109 | bind::commonBindings evalDbgWin {} 110 | bind $evalText { 111 | evalWin::moveLevel -1; break 112 | } 113 | bind $evalText { 114 | evalWin::moveLevel 1; break 115 | } 116 | foreach num [list 0 1 2 3 4 5 6 7 8 9] { 117 | bind $evalText " 118 | evalWin::requestLevel $num; break 119 | " 120 | } 121 | if {[gui::getCurrentState] == "running"} { 122 | bind::addBindTags $evalText disableKeys 123 | evalWin::resetWindow 124 | } 125 | bind $top "$closeBut invoke; break" 126 | } 127 | 128 | # evalWin::updateWindow -- 129 | # 130 | # Update the display of the Eval Window. 131 | # 132 | # Arguments: 133 | # None. 134 | # 135 | # Results: 136 | # None. 137 | 138 | proc evalWin::updateWindow {} { 139 | variable evalText 140 | variable levelCombo 141 | variable afterID 142 | 143 | if {![winfo exists $gui::gui(evalDbgWin)]} { 144 | return 145 | } 146 | 147 | if {[info exists afterID]} { 148 | after cancel $afterID 149 | unset afterID 150 | } 151 | 152 | # Enable typing in the console and remove the disabled 153 | # look of the console by removing the disabled tags. 154 | 155 | $evalText tag remove disable 0.0 "end + 1 lines" 156 | bind::removeBindTag $evalWin::evalText disableKeys 157 | 158 | set state [gui::getCurrentState] 159 | if {$state == "stopped"} { 160 | # Add the list of valid levels to the level combo box 161 | # and set the display in the combo entry to the top 162 | # stack level. 163 | 164 | set thisLevel $gui::gui(evalLevelVar) 165 | $levelCombo del 0 end 166 | set levels [evalWin::getLevels] 167 | eval {$levelCombo add} $levels 168 | $evalText configure -state normal 169 | 170 | # Set the default level. If the "stopped" event was generated 171 | # by a "result" break type, use the last level as long as it 172 | # still exists. Otherwise use the top-most level. 173 | 174 | set lastLevel [lindex $levels end] 175 | if {([gui::getCurrentBreak] == "result") && $thisLevel < $lastLevel} { 176 | set gui::gui(evalLevelVar) $thisLevel 177 | } else { 178 | set gui::gui(evalLevelVar) $lastLevel 179 | } 180 | } elseif {$state == "running"} { 181 | # Append the bindtag that will disable key strokes. 182 | bind::addBindTags $evalText disableKeys 183 | set afterID [after $gui::afterTime ::evalWin::resetWindow] 184 | } else { 185 | evalWin::resetWindow 186 | } 187 | } 188 | 189 | # evalWin::resetWindow -- 190 | # 191 | # Reset the display of the Eval Window. If the message 192 | # passed in is not empty, display the contents of the 193 | # message in the evalText window. 194 | # 195 | # Arguments: 196 | # msg If this is not an empty string then display this 197 | # message in the evatText window. 198 | # 199 | # Results: 200 | # None. 201 | 202 | proc evalWin::resetWindow {{msg {}}} { 203 | variable evalText 204 | variable levelCombo 205 | 206 | if {![winfo exists $gui::gui(evalDbgWin)]} { 207 | return 208 | } 209 | 210 | $levelCombo del 0 end 211 | $evalText configure -state disabled 212 | $evalText tag add disable 0.0 "end + 1 lines" 213 | } 214 | 215 | # evalWin::evalCmd -- 216 | # 217 | # Evaluate the next command in the evalText window. 218 | # This proc is called by the TkCon code defined in 219 | # tkcon.tcl. 220 | # 221 | # Arguments: 222 | # cmd The command to evaluate. 223 | # 224 | # Results: 225 | # The "pid" of the command. 226 | 227 | proc evalWin::evalCmd {cmd} { 228 | return [gui::run [list dbg::evaluate $gui::gui(evalLevelVar) $cmd]] 229 | } 230 | 231 | # evalWin::evalResult -- 232 | # 233 | # Handler for the "result" message sent from the nub. 234 | # Pass the data to TkCon to display the result. 235 | # 236 | # Arguments: 237 | # id The "pid" of the command. 238 | # code Standard Tcl result code. 239 | # result The result of evaluation. 240 | # errCode The errorCode of the eval. 241 | # errInfo The stack trace of the error. 242 | # 243 | # Results: 244 | # None. 245 | 246 | proc evalWin::evalResult {id code result errCode errInfo} { 247 | set code [code::binaryClean $code] 248 | set result [code::binaryClean $result] 249 | set errCode [code::binaryClean $errCode] 250 | set errInfo [code::binaryClean $errInfo] 251 | 252 | tkCon::EvalResult $id $code $result $errCode $errInfo 253 | } 254 | 255 | # evalWin::moveLevel -- 256 | # 257 | # Move the current eval level up or down within range 258 | # of acceptable levels. 259 | # 260 | # Arguments: 261 | # amount The amount to increment/decrement to the 262 | # current level. 263 | # 264 | # Results: 265 | # None. 266 | 267 | proc evalWin::moveLevel {amount} { 268 | variable levelCombo 269 | 270 | set level [expr {[$levelCombo get] + $amount}] 271 | set last [lindex [evalWin::getLevels] end] 272 | 273 | if {$last == {}} { 274 | return 275 | } 276 | if {$level < 0} { 277 | set level 0 278 | } 279 | if {$level > $last} { 280 | set level $last 281 | } 282 | $levelCombo set $level 283 | } 284 | 285 | # evalWin::requestLevel -- 286 | # 287 | # Request a level, between 0 and 9, to evaluate the next 288 | # command in. If the level is invalid, do nothing. 289 | # 290 | # Arguments: 291 | # level A requested eval level between 0 and 9. 292 | # 293 | # Results: 294 | # None. 295 | 296 | proc evalWin::requestLevel {level} { 297 | variable levelCombo 298 | 299 | if {[lsearch [evalWin::getLevels] $level] >= 0} { 300 | $levelCombo set $level 301 | } 302 | } 303 | 304 | # evalWin::getLevels -- 305 | # 306 | # Get a list of valid level to eval the command in. 307 | # 308 | # Arguments: 309 | # None. 310 | # 311 | # Results: 312 | # None. 313 | 314 | proc evalWin::getLevels {} { 315 | variable evalText 316 | variable levelCombo 317 | 318 | set maxLevel [dbg::getLevel] 319 | set result {} 320 | for {set i 0} {$i <= $maxLevel} {incr i} { 321 | lappend result $i 322 | } 323 | return $result 324 | } 325 | --------------------------------------------------------------------------------