1#!/bin/sh 2# -*- tcl -*- 3# \ 4exec wish "$0" ${1+"$@"} 5 6# 7## tkcon.tcl 8## Enhanced Tk Console, part of the VerTcl system 9## 10## Originally based off Brent Welch's Tcl Shell Widget 11## (from "Practical Programming in Tcl and Tk") 12## 13## Thanks to the following (among many) for early bug reports & code ideas: 14## Steven Wahl, Jan Nijtmans, Mark Crimmins, Wart 15## 16## Copyright (c) 1995-2009 Jeffrey Hobbs, jeff(a)hobbs(.)org 17## Initiated: Thu Aug 17 15:36:47 PDT 1995 18## 19## source standard_disclaimer.tcl 20## source bourbon_ware.tcl 21## 22 23# Proxy support for retrieving the current version of Tkcon. 24# 25# Mon Jun 25 12:19:56 2001 - Pat Thoyts 26# 27# In your tkcon.cfg or .tkconrc file put your proxy details into the 28# `proxy' member of the `PRIV' array. e.g.: 29# 30# set ::tkcon::PRIV(proxy) wwwproxy:8080 31# 32# If you want to be prompted for proxy authentication details (eg for 33# an NT proxy server) make the second element of this variable non-nil - eg: 34# 35# set ::tkcon::PRIV(proxy) {wwwproxy:8080 1} 36# 37# Or you can set the above variable from within tkcon by calling 38# 39# tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080 40# 41 42if {$tcl_version < 8.4} { 43 return -code error "tkcon requires at least Tcl/Tk 8.4" 44} else { 45 package require Tk 8.4 46} 47 48# We need to load some package to get what's available, and we 49# choose ctext because we'll use it if its available in the editor 50catch {package require ctext} 51foreach pkg [info loaded {}] { 52 set file [lindex $pkg 0] 53 set name [lindex $pkg 1] 54 if {![catch {set version [package require $name]}]} { 55 if {[package ifneeded $name $version] eq ""} { 56 package ifneeded $name $version [list load $file $name] 57 } 58 } 59} 60 61# Unset temporary global vars 62catch {unset pkg file name version} 63 64# Initialize the ::tkcon namespace 65# 66namespace eval ::tkcon { 67 # when modifying this line, make sure that the auto-upgrade check 68 # for version still works. 69 variable VERSION "2.6" 70 # The OPT variable is an array containing most of the optional 71 # info to configure. COLOR has the color data. 72 variable OPT 73 variable COLOR 74 75 # PRIV is used for internal data that only tkcon should fiddle with. 76 variable PRIV 77 set PRIV(WWW) [info exists embed_args] 78 79 variable EXPECT 0 80} 81 82## ::tkcon::Init - inits tkcon 83# 84# Calls: ::tkcon::InitUI 85# Outputs: errors found in tkcon's resource file 86## 87proc ::tkcon::Init {args} { 88 variable VERSION 89 variable OPT 90 variable COLOR 91 variable PRIV 92 global tcl_platform env tcl_interactive errorInfo 93 94 set tcl_interactive 1 95 set argc [llength $args] 96 97 ## 98 ## When setting up all the default values, we always check for 99 ## prior existence. This allows users who embed tkcon to modify 100 ## the initial state before tkcon initializes itself. 101 ## 102 103 # bg == {} will get bg color from the main toplevel (in InitUI) 104 foreach {key default} { 105 bg {} 106 blink \#FFFF00 107 cursor \#000000 108 disabled \#4D4D4D 109 proc \#008800 110 var \#FFC0D0 111 prompt \#8F4433 112 stdin \#000000 113 stdout \#0000FF 114 stderr \#FF0000 115 } { 116 if {![info exists COLOR($key)]} { set COLOR($key) $default } 117 } 118 119 # expandorder could also include 'Xotcl' (before Procname) 120 foreach {key default} { 121 autoload {} 122 blinktime 500 123 blinkrange 1 124 buffer 512 125 maxlinelen 0 126 calcmode 0 127 cols 80 128 debugPrompt {(level \#$level) debug [history nextid] > } 129 dead {} 130 edit edit 131 expandorder {Pathname Variable Procname} 132 font {} 133 history 48 134 hoterrors 1 135 library {} 136 lightbrace 1 137 lightcmd 1 138 maineval {} 139 maxmenu 18 140 nontcl 0 141 prompt1 {ignore this, it's set below} 142 rows 20 143 scrollypos right 144 showmenu 1 145 showmultiple 1 146 showstatusbar 1 147 slaveeval {} 148 slaveexit close 149 subhistory 1 150 gc-delay 60000 151 gets {congets} 152 overrideexit 1 153 usehistory 1 154 resultfilter {} 155 156 exec slave 157 } { 158 if {![info exists OPT($key)]} { set OPT($key) $default } 159 } 160 161 foreach {key default} { 162 app {} 163 appname {} 164 apptype slave 165 namesp :: 166 cmd {} 167 cmdbuf {} 168 cmdsave {} 169 event 1 170 deadapp 0 171 deadsock 0 172 debugging 0 173 displayWin . 174 histid 0 175 find {} 176 find,case 0 177 find,reg 0 178 errorInfo {} 179 protocol exit 180 showOnStartup 1 181 slaveprocs { 182 alias clear dir dump echo idebug lremove 183 tkcon_puts tkcon_gets observe observe_var unalias which what 184 } 185 RCS {RCS: @(#) $Id: tkcon.tcl,v 1.111 2010/01/24 01:25:26 patthoyts Exp $} 186 HEADURL {http://tkcon.cvs.sourceforge.net/tkcon/tkcon/tkcon.tcl?rev=HEAD} 187 188 docs "http://tkcon.sourceforge.net/" 189 email {jeff(a)hobbs(.)org} 190 root . 191 uid 0 192 tabs {} 193 } { 194 if {![info exists PRIV($key)]} { set PRIV($key) $default } 195 } 196 foreach {key default} { 197 slavealias { $OPT(edit) more less tkcon } 198 } { 199 if {![info exists PRIV($key)]} { set PRIV($key) [subst $default] } 200 } 201 set PRIV(version) $VERSION 202 203 if {[info exists PRIV(name)]} { 204 set title $PRIV(name) 205 } else { 206 MainInit 207 # some main initialization occurs later in this proc, 208 # to go after the UI init 209 set MainInit 1 210 set title Main 211 } 212 213 ## NOTES FOR STAYING IN PRIMARY INTERPRETER: 214 ## 215 ## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple 216 ## interp model, you get tkcon operating in the main interp by default. 217 ## This can be useful when attaching to programs that like to operate 218 ## in the main interpter (for example, based on special wish'es). 219 ## You can set this from the command line with -exec "" 220 ## A side effect is that all tkcon command line args will be used 221 ## by the first console only. 222 #set OPT(exec) {} 223 224 if {$PRIV(WWW)} { 225 lappend PRIV(slavealias) history 226 set OPT(prompt1) {[history nextid] % } 227 } else { 228 lappend PRIV(slaveprocs) tcl_unknown unknown 229 set OPT(prompt1) {([file tail [pwd]]) [history nextid] % } 230 } 231 232 ## If we are using the default '.' toplevel, and there appear to be 233 ## children of '.', then make sure we use a disassociated toplevel. 234 if {$PRIV(root) == "." && [llength [winfo children .]]} { 235 set PRIV(root) .tkcon 236 } 237 238 ## Do platform specific configuration here, other than defaults 239 ### Use tkcon.cfg filename for resource filename on non-unix systems 240 ### Determine what directory the resource file should be in 241 switch $tcl_platform(platform) { 242 macintosh { 243 if {![interp issafe]} {cd [file dirname [info script]]} 244 set envHome PREF_FOLDER 245 set rcfile tkcon.cfg 246 set histfile tkcon.hst 247 catch {console hide} 248 } 249 windows { 250 set envHome HOME 251 set rcfile tkcon.cfg 252 set histfile tkcon.hst 253 } 254 unix { 255 set envHome HOME 256 set rcfile .tkconrc 257 set histfile .tkcon_history 258 } 259 } 260 if {[info exists env($envHome)]} { 261 set home $env($envHome) 262 if {[file pathtype $home] == "volumerelative"} { 263 # Convert 'C:' to 'C:/' if necessary, innocuous otherwise 264 append home / 265 } 266 if {![info exists PRIV(rcfile)]} { 267 set PRIV(rcfile) [file join $home $rcfile] 268 } 269 if {![info exists PRIV(histfile)]} { 270 set PRIV(histfile) [file join $home $histfile] 271 } 272 } 273 274 ## Handle command line arguments before sourcing resource file to 275 ## find if resource file is being specified (let other args pass). 276 if {[set i [lsearch -exact $args -rcfile]] != -1} { 277 set PRIV(rcfile) [lindex $args [incr i]] 278 } 279 280 if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} { 281 set code [catch {uplevel \#0 [list source $PRIV(rcfile)]} err] 282 } 283 284 if {[info exists env(TK_CON_LIBRARY)]} { 285 lappend ::auto_path $env(TK_CON_LIBRARY) 286 } elseif {$OPT(library) != ""} { 287 lappend ::auto_path $OPT(library) 288 } 289 290 if {![info exists ::tcl_pkgPath]} { 291 set dir [file join [file dirname [info nameofexec]] lib] 292 if {[llength [info commands @scope]]} { 293 set dir [file join $dir itcl] 294 } 295 catch {source [file join $dir pkgIndex.tcl]} 296 } 297 catch {tclPkgUnknown dummy-name dummy-version} 298 299 ## Handle rest of command line arguments after sourcing resource file 300 ## and slave is created, but before initializing UI or setting packages. 301 set slaveargs {} 302 set slavefiles {} 303 set slaveargv0 {} 304 set truth {^(1|yes|true|on)$} 305 for {set i 0} {$i < $argc} {incr i} { 306 set arg [lindex $args $i] 307 if {[string match {-*} $arg]} { 308 set val [lindex $args [incr i]] 309 ## Handle arg based options 310 switch -glob -- $arg { 311 -- - -argv - -args { 312 set slaveargs [concat $slaveargs [lrange $args $i end]] 313 set ::argv $slaveargs 314 set ::argc [llength $::argv] 315 break 316 } 317 -color-* { set COLOR([string range $arg 7 end]) $val } 318 -exec { set OPT(exec) $val } 319 -main - -e - -eval { append OPT(maineval) \n$val\n } 320 -package - -load { lappend OPT(autoload) $val } 321 -slave { append OPT(slaveeval) \n$val\n } 322 -nontcl { set OPT(nontcl) [regexp -nocase $truth $val]} 323 -root { set PRIV(root) $val } 324 -font { set OPT(font) $val } 325 -rcfile {} 326 default { lappend slaveargs $arg; incr i -1 } 327 } 328 } elseif {[file isfile $arg]} { 329 if {$i == 0} { 330 set slaveargv0 $arg 331 } 332 lappend slavefiles $arg 333 } else { 334 lappend slaveargs $arg 335 } 336 } 337 338 ## Create slave executable 339 if {"" != $OPT(exec)} { 340 InitSlave $OPT(exec) $slaveargs $slaveargv0 341 } else { 342 set argc [llength $slaveargs] 343 set args $slaveargs 344 uplevel \#0 $slaveargs 345 } 346 347 # Try not to make tkcon override too many standard defaults, and only 348 # do it for the tkcon bits 349 set optclass [tk appname]$PRIV(root) 350 option add $optclass*Menu.tearOff 0 351 option add $optclass*Menu.borderWidth 1 352 option add $optclass*Menu.activeBorderWidth 1 353 if {$::tcl_version >= 8.4 && [tk windowingsystem] != "aqua"} { 354 option add $optclass*Scrollbar.borderWidth 1 355 } 356 357 ## Attach to the slave, EvalAttached will then be effective 358 Attach $PRIV(appname) $PRIV(apptype) 359 InitUI $title 360 if {"" != $OPT(exec)} { 361 # override exit to DeleteTab now that tab has been created 362 $OPT(exec) alias exit ::tkcon::DeleteTab $PRIV(curtab) $OPT(exec) 363 } 364 365 ## swap puts and gets with the tkcon versions to make sure all 366 ## input and output is handled by tkcon 367 if {![catch {rename ::puts ::tkcon_tcl_puts}]} { 368 interp alias {} ::puts {} ::tkcon_puts 369 if {[llength [info commands ::tcl::chan::puts]]} { 370 interp alias {} ::tcl::chan::puts {} ::tkcon_puts 371 } 372 } 373 if {($OPT(gets) != "") && ![catch {rename ::gets ::tkcon_tcl_gets}]} { 374 interp alias {} ::gets {} ::tkcon_gets 375 if {[llength [info commands ::tcl::chan::gets]]} { 376 interp alias {} ::tcl::chan::gets {} ::tkcon_gets 377 } 378 } 379 380 EvalSlave history keep $OPT(history) 381 if {[info exists MainInit]} { 382 # Source history file only for the main console, as all slave 383 # consoles will adopt from the main's history, but still 384 # keep separate histories 385 if {!$PRIV(WWW) && $OPT(usehistory) && [file exists $PRIV(histfile)]} { 386 puts -nonewline "loading history file ... " 387 # The history file is built to be loaded in and 388 # understood by tkcon 389 if {[catch {uplevel \#0 [list source $PRIV(histfile)]} herr]} { 390 puts stderr "error:\n$herr" 391 append PRIV(errorInfo) $errorInfo\n 392 } 393 set PRIV(event) [EvalSlave history nextid] 394 puts "[expr {$PRIV(event)-1}] events added" 395 } 396 } 397 398 ## Autoload specified packages in slave 399 set pkgs [EvalSlave package names] 400 foreach pkg $OPT(autoload) { 401 puts -nonewline "autoloading package \"$pkg\" ... " 402 if {[lsearch -exact $pkgs $pkg]>-1} { 403 if {[catch {EvalSlave package require [list $pkg]} pkgerr]} { 404 puts stderr "error:\n$pkgerr" 405 append PRIV(errorInfo) $errorInfo\n 406 } else { puts "OK" } 407 } else { 408 puts stderr "error: package does not exist" 409 } 410 } 411 412 ## Evaluate maineval in slave 413 if {($OPT(maineval) ne "") && [catch {uplevel \#0 $OPT(maineval)} merr]} { 414 puts stderr "error in eval:\n$merr" 415 append PRIV(errorInfo) $errorInfo\n 416 } 417 418 ## Source extra command line argument files into slave executable 419 foreach fn $slavefiles { 420 puts -nonewline "slave sourcing \"$fn\" ... " 421 if {[catch {EvalSlave uplevel \#0 [list source $fn]} fnerr]} { 422 puts stderr "error:\n$fnerr" 423 append PRIV(errorInfo) $errorInfo\n 424 } else { puts "OK" } 425 } 426 427 ## Evaluate slaveeval in slave 428 if {($OPT(slaveeval) ne "") 429 && [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} { 430 puts stderr "error in slave eval:\n$serr" 431 append PRIV(errorInfo) $errorInfo\n 432 } 433 ## Output any error/output that may have been returned from rcfile 434 if {[info exists code] && $code && ($err ne "")} { 435 puts stderr "error in $PRIV(rcfile):\n$err" 436 append PRIV(errorInfo) $errorInfo 437 } 438 if {$OPT(exec) ne ""} { 439 StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave 440 } 441 StateCheckpoint $PRIV(name) slave 442 443 puts "buffer line limit:\ 444 [expr {$OPT(buffer)?$OPT(buffer):{unlimited}}] \ 445 max line length:\ 446 [expr {$OPT(maxlinelen)?$OPT(maxlinelen):{unlimited}}]" 447 448 Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n" 449} 450 451## ::tkcon::InitSlave - inits the slave by placing key procs and aliases in it 452## It's arg[cv] are based on passed in options, while argv0 is the same as 453## the master. tcl_interactive is the same as the master as well. 454# ARGS: slave - name of slave to init. If it does not exist, it is created. 455# args - args to pass to a slave as argv/argc 456## 457proc ::tkcon::InitSlave {slave {slaveargs {}} {slaveargv0 {}}} { 458 variable OPT 459 variable COLOR 460 variable PRIV 461 global argv0 tcl_interactive tcl_library env auto_path tk_library 462 463 if {$slave eq ""} { 464 return -code error "Don't init the master interpreter, goofball" 465 } 466 if {![interp exists $slave]} { interp create $slave } 467 if {[interp eval $slave info command source] == ""} { 468 $slave alias source SafeSource $slave 469 $slave alias load SafeLoad $slave 470 $slave alias open SafeOpen $slave 471 $slave alias file file 472 interp eval $slave \ 473 [list set auto_path [lremove $auto_path $tk_library]] 474 interp eval $slave [dump var -nocomplain tcl_library env] 475 interp eval $slave { catch {source [file join $tcl_library init.tcl]} } 476 interp eval $slave { catch unknown } 477 } 478 # This will likely be overridden to call DeleteTab where possible 479 $slave alias exit exit 480 interp eval $slave { 481 # Do package require before changing around puts/gets 482 catch {set __tkcon_error ""; set __tkcon_error $errorInfo} 483 catch {package require bogus-package-name} 484 catch {rename ::puts ::tkcon_tcl_puts} 485 set errorInfo ${__tkcon_error} 486 unset __tkcon_error 487 } 488 foreach cmd $PRIV(slaveprocs) { $slave eval [dump proc $cmd] } 489 foreach cmd $PRIV(slavealias) { $slave alias $cmd $cmd } 490 interp alias $slave ::ls $slave ::dir -full 491 interp alias $slave ::puts $slave ::tkcon_puts 492 if {[llength [info commands ::tcl::chan::puts]]} { 493 interp alias $slave ::tcl::chan::puts $slave ::tkcon_puts 494 } 495 if {$OPT(gets) != ""} { 496 interp eval $slave { catch {rename ::gets ::tkcon_tcl_gets} } 497 interp alias $slave ::gets $slave ::tkcon_gets 498 if {[llength [info commands ::tcl::chan::gets]]} { 499 interp alias $slave ::tcl::chan::gets $slave ::tkcon_gets 500 } 501 } 502 if {$slaveargv0 != ""} { 503 # If tkcon was invoked with 1 or more filenames, then make the 504 # first filename argv0 in the slave, as tclsh/wish would do it. 505 interp eval $slave [list set argv0 $slaveargv0] 506 } else { 507 if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]} 508 } 509 interp eval $slave set tcl_interactive $tcl_interactive \; \ 510 set auto_path [list [lremove $auto_path $tk_library]] \; \ 511 set argc [llength $slaveargs] \; \ 512 set argv [list $slaveargs] \; { 513 if {![llength [info command bgerror]]} { 514 proc bgerror err { 515 global errorInfo 516 set body [info body bgerror] 517 rename ::bgerror {} 518 if {[auto_load bgerror]} { return [bgerror $err] } 519 proc bgerror err $body 520 tkcon bgerror $err $errorInfo 521 } 522 } 523 } 524 525 foreach pkg [lremove [package names] Tcl] { 526 foreach v [package versions $pkg] { 527 interp eval $slave [list package ifneeded $pkg $v \ 528 [package ifneeded $pkg $v]] 529 } 530 } 531} 532 533## ::tkcon::InitInterp - inits an interpreter by placing key 534## procs and aliases in it. 535# ARGS: name - interp name 536# type - interp type (slave|interp) 537## 538proc ::tkcon::InitInterp {name type} { 539 variable OPT 540 variable PRIV 541 542 ## Don't allow messing up a local master interpreter 543 if {($type eq "namespace") 544 || (($type eq "slave") && 545 [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} { return } 546 set old [Attach] 547 set oldname $PRIV(namesp) 548 catch { 549 Attach $name $type 550 EvalAttached { catch {rename ::puts ::tkcon_tcl_puts} } 551 foreach cmd $PRIV(slaveprocs) { EvalAttached [dump proc $cmd] } 552 switch -exact $type { 553 slave { 554 foreach cmd $PRIV(slavealias) { 555 Main interp alias $name ::$cmd $PRIV(name) ::$cmd 556 } 557 } 558 interp { 559 set thistkcon [::send::appname] 560 foreach cmd $PRIV(slavealias) { 561 EvalAttached "proc $cmd args { ::send::send [list $thistkcon] $cmd \$args }" 562 } 563 } 564 } 565 ## Catch in case it's a 7.4 (no 'interp alias') interp 566 EvalAttached { 567 catch {interp alias {} ::ls {} ::dir -full} 568 if {[catch {interp alias {} ::puts {} ::tkcon_puts}]} { 569 catch {rename ::tkcon_puts ::puts} 570 } elseif {[llength [info commands ::tcl::chan::puts]]} { 571 catch {interp alias {} ::tcl::chan::puts {} ::tkcon_puts} 572 } 573 } 574 if {$OPT(gets) != ""} { 575 EvalAttached { 576 catch {rename ::gets ::tkcon_tcl_gets} 577 if {[catch {interp alias {} ::gets {} ::tkcon_gets}]} { 578 catch {rename ::tkcon_gets ::gets} 579 } elseif {[llength [info commands ::tcl::chan::gets]]} { 580 catch {interp alias {} ::tcl::chan::gets {} ::tkcon_gets} 581 } 582 } 583 } 584 return 585 } {err} 586 eval Attach $old 587 AttachNamespace $oldname 588 if {$err ne ""} { return -code error $err } 589} 590 591## ::tkcon::InitUI - inits UI portion (console) of tkcon 592## Creates all elements of the console window and sets up the text tags 593# ARGS: root - widget pathname of the tkcon console root 594# title - title for the console root and main (.) windows 595# Calls: ::tkcon::InitMenus, ::tkcon::Prompt 596## 597proc ::tkcon::InitUI {title} { 598 variable OPT 599 variable PRIV 600 variable COLOR 601 602 set root $PRIV(root) 603 if {$root eq "."} { set w {} } else { set w [toplevel $root] } 604 if {!$PRIV(WWW)} { 605 wm withdraw $root 606 wm protocol $root WM_DELETE_WINDOW $PRIV(protocol) 607 } 608 set PRIV(base) $w 609 610 catch {font create tkconfixed -family Courier -size -12} 611 catch {font create tkconfixedbold -family Courier -size -12 -weight bold} 612 613 set PRIV(statusbar) [set sbar [frame $w.fstatus]] 614 set PRIV(tabframe) [frame $sbar.tabs] 615 set PRIV(X) [button $sbar.deltab -text "X" -command ::tkcon::DeleteTab \ 616 -activeforeground red -fg red -font tkconfixedbold \ 617 -highlightthickness 0 -padx 2 -pady 0 -borderwidth 1 \ 618 -state disabled -relief flat -takefocus 0] 619 catch {$PRIV(X) configure -overrelief raised} 620 label $sbar.cursor -relief sunken -borderwidth 1 -anchor e -width 6 \ 621 -textvariable ::tkcon::PRIV(StatusCursor) 622 set padx [expr {![info exists ::tcl_platform(os)] 623 || ($::tcl_platform(os) ne "Windows CE")}] 624 grid $PRIV(X) $PRIV(tabframe) $sbar.cursor -sticky news -padx $padx 625 grid configure $PRIV(tabframe) -sticky nsw 626 grid configure $PRIV(X) -pady 0 -padx 0 627 grid columnconfigure $sbar 1 -weight 1 628 grid rowconfigure $sbar 0 -weight 1 629 grid rowconfigure $PRIV(tabframe) 0 -weight 1 630 if {$::tcl_version >= 8.4 && [tk windowingsystem] == "aqua"} { 631 # resize control space 632 grid columnconfigure $sbar [lindex [grid size $sbar] 0] -minsize 16 633 } 634 635 ## Create console tab 636 set con [InitTab $w] 637 set PRIV(curtab) $con 638 639 # Only apply this for the first console 640 $con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows) 641 bind $PRIV(root) <Configure> { 642 if {"%W" == $::tkcon::PRIV(root)} { 643 scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \ 644 ::tkcon::OPT(cols) ::tkcon::OPT(rows) 645 if {[info exists ::tkcon::EXP(spawn_id)]} { 646 catch {stty rows $::tkcon::OPT(rows) columns \ 647 $::tkcon::OPT(cols) < $::tkcon::EXP(slave,name)} 648 } 649 } 650 } 651 652 # scrollbar 653 set sy [scrollbar $w.sy -takefocus 0 -command [list $con yview]] 654 if {!$PRIV(WWW) && ($::tcl_platform(os) eq "Windows CE")} { 655 $w.sy configure -width 10 656 } 657 658 $con configure -yscrollcommand [list $sy set] 659 set PRIV(console) $con 660 set PRIV(scrolly) $sy 661 662 ## Menus 663 ## catch against use in plugin 664 if {[catch {menu $w.mbar} PRIV(menubar)]} { 665 set PRIV(menubar) [frame $w.mbar -relief raised -borderwidth 1] 666 } 667 668 InitMenus $PRIV(menubar) $title 669 Bindings 670 671 if {$OPT(showmenu)} { 672 $root configure -menu $PRIV(menubar) 673 } 674 675 grid $con -row 1 -column 1 -sticky news 676 grid $sy -row 1 -column [expr {$OPT(scrollypos)=="left"?0:2}] -sticky ns 677 grid $sbar -row 2 -column 0 -columnspan 3 -sticky ew 678 679 grid columnconfigure $root 1 -weight 1 680 grid rowconfigure $root 1 -weight 1 681 682 if {!$OPT(showstatusbar)} { 683 grid remove $sbar 684 } 685 686 # If we can locate the XDG icon file then make use of it. 687 if {[package vsatisfies [package provide Tk] 8.6]} { 688 if {[tk windowingsystem] eq "x11"} { 689 if {[set icon [locate_xdg_icon tkcon-icon.png]] ne ""} { 690 image create photo tkcon_icon -file $icon 691 wm iconphoto $root tkcon_icon 692 } 693 } 694 } 695 696 if {!$PRIV(WWW)} { 697 wm title $root "tkcon $PRIV(version) $title" 698 if {$PRIV(showOnStartup)} { wm deiconify $root } 699 } 700 if {$PRIV(showOnStartup)} { focus -force $PRIV(console) } 701 if {$OPT(gc-delay)} { 702 after $OPT(gc-delay) ::tkcon::GarbageCollect 703 } 704} 705 706# Hunt around the XDG defined directories for the icon. 707# Note: hicolor is the standard theme used by xdg-icon-resource. 708proc ::tkcon::locate_xdg_icon {name} { 709 global env 710 set dirs [list /usr/local/share /usr/share] 711 if {[info exists env(XDG_DATA_DIRS)]} { 712 set dirs [split $env(XDG_DATA_DIRS) :] 713 } 714 if {[file isdirectory ~/.local/share]} { 715 set dirs [linsert $dirs 0 ~/.local/share] 716 } 717 foreach dir $dirs { 718 foreach path [list icons icons/hicolor/48x48/apps] { 719 set path [file join $dir $path $name] 720 if {[file exists $path]} { 721 return $path 722 } 723 } 724 } 725 return "" 726} 727 728proc ::tkcon::InitTab {w} { 729 variable OPT 730 variable PRIV 731 variable COLOR 732 variable ATTACH 733 734 # text console 735 set con $w.tab[incr PRIV(uid)] 736 text $con -wrap char -foreground $COLOR(stdin) \ 737 -insertbackground $COLOR(cursor) -borderwidth 1 -highlightthickness 0 738 $con mark set output 1.0 739 $con mark set limit 1.0 740 if {$COLOR(bg) ne ""} { 741 $con configure -background $COLOR(bg) 742 } 743 set COLOR(bg) [$con cget -background] 744 if {$OPT(font) ne ""} { 745 ## Set user-requested font, if any 746 $con configure -font $OPT(font) 747 } elseif {$::tcl_platform(platform) ne "unix"} { 748 ## otherwise make sure the font is monospace 749 set font [$con cget -font] 750 if {![font metrics $font -fixed]} { 751 $con configure -font tkconfixed 752 } 753 } else { 754 $con configure -font tkconfixed 755 } 756 set OPT(font) [$con cget -font] 757 bindtags $con [list $con TkConsole TkConsolePost $PRIV(root) all] 758 759 # scrollbar 760 if {!$PRIV(WWW)} { 761 if {$::tcl_platform(os) eq "Windows CE"} { 762 font configure tkconfixed -family Tahoma -size 8 763 $con configure -font tkconfixed -borderwidth 0 -padx 0 -pady 0 764 set cw [font measure tkconfixed "0"] 765 set ch [font metrics tkconfixed -linespace] 766 set sw [winfo screenwidth $con] 767 set sh [winfo screenheight $con] 768 # We need the magic hard offsets until I find a way to 769 # correctly assume size 770 if {$cw*($OPT(cols)+2) > $sw} { 771 set OPT(cols) [expr {($sw / $cw) - 2}] 772 } 773 if {$ch*($OPT(rows)+3) > $sh} { 774 set OPT(rows) [expr {($sh / $ch) - 3}] 775 } 776 # Place it so that the titlebar underlaps the CE titlebar 777 wm geometry $PRIV(root) +0+0 778 } 779 } 780 $con configure -height $OPT(rows) -width $OPT(cols) 781 782 foreach col {prompt stdout stderr stdin proc} { 783 $con tag configure $col -foreground $COLOR($col) 784 } 785 $con tag configure var -background $COLOR(var) 786 $con tag raise sel 787 $con tag configure blink -background $COLOR(blink) 788 $con tag configure find -background $COLOR(blink) 789 790 set ATTACH($con) [Attach] 791 set rb [radiobutton $PRIV(tabframe).cb[winfo name $con] -takefocus 0 \ 792 -textvariable ::tkcon::ATTACH($con) \ 793 -selectcolor white -relief sunken \ 794 -indicatoron 0 -padx 0 -pady 0 -borderwidth 1 \ 795 -variable ::tkcon::PRIV(curtab) -value $con \ 796 -command [list ::tkcon::GotoTab $con]] 797 if {$::tcl_version >= 8.4} { 798 $rb configure -offrelief flat -overrelief raised 799 } 800 grid $rb -row 0 -column [lindex [grid size $PRIV(tabframe)] 0] -sticky ns 801 grid $con -row 1 -column 1 -sticky news 802 803 lappend PRIV(tabs) $con 804 return $con 805} 806 807proc ::tkcon::GotoTab {con} { 808 variable PRIV 809 variable ATTACH 810 811 set numtabs [llength $PRIV(tabs)] 812 #if {$numtabs == 1} { return } 813 814 if {[regexp {^[0-9]+$} $con]} { 815 set curtab [lsearch -exact $PRIV(tabs) $PRIV(console)] 816 set nexttab [expr {$curtab + $con}] 817 if {$nexttab >= $numtabs} { 818 set nexttab 0 819 } elseif {$nexttab < 0} { 820 set nexttab "end" 821 } 822 set con [lindex $PRIV(tabs) $nexttab] 823 } elseif {$con == $PRIV(console)} { 824 return 825 } 826 827 # adjust console 828 if {[winfo exists $PRIV(console)]} { 829 lower $PRIV(console) 830 $PRIV(console) configure -yscrollcommand {} 831 set ATTACH($PRIV(console)) [Attach] 832 } 833 set PRIV(console) $con 834 $con configure -yscrollcommand [list $PRIV(scrolly) set] 835 $PRIV(scrolly) configure -command [list $con yview] 836 837 # adjust attach 838 eval [linsert $ATTACH($con) 0 Attach] 839 840 set PRIV(curtab) $con 841 842 raise $con 843 844 if {[$con compare 1.0 == end-1c]} { 845 Prompt 846 } 847 848 # set StatusCursor 849 set PRIV(StatusCursor) [$con index insert] 850 851 focus -force $con 852} 853 854proc ::tkcon::NewTab {{con {}}} { 855 variable PRIV 856 variable ATTACH 857 858 set con [InitTab $PRIV(base)] 859 set slave [GetSlave] 860 InitSlave $slave 861 $slave alias exit ::tkcon::DeleteTab $con $slave 862 if {$PRIV(name) != ""} { 863 set ATTACH($con) [list [list $PRIV(name) $slave] slave] 864 } else { 865 set ATTACH($con) [list $slave slave] 866 } 867 $PRIV(X) configure -state normal 868 MenuConfigure Console "Delete Tab" -state normal 869 GotoTab $con 870} 871 872# The extra code arg is for the alias of exit to this function 873proc ::tkcon::DeleteTab {{con {}} {slave {}} {code 0}} { 874 variable PRIV 875 876 set numtabs [llength $PRIV(tabs)] 877 if {$numtabs <= 2} { 878 $PRIV(X) configure -state disabled 879 MenuConfigure Console "Delete Tab" -state disabled 880 } 881 if {$numtabs == 1} { 882 # in the master, it should do the right thing 883 # currently the first master still exists - need rearch to fix 884 exit 885 # we might end up here, depending on how exit is rerouted 886 return 887 } 888 889 if {$con == ""} { 890 set con $PRIV(console) 891 } 892 catch {unset ATTACH($con)} 893 set curtab [lsearch -exact $PRIV(tabs) $con] 894 set PRIV(tabs) [lreplace $PRIV(tabs) $curtab $curtab] 895 896 set numtabs [llength $PRIV(tabs)] 897 set nexttab $curtab 898 if {$nexttab >= $numtabs} { 899 set nexttab end 900 } 901 set nexttab [lindex $PRIV(tabs) $nexttab] 902 903 GotoTab $nexttab 904 905 if {$slave != "" && $slave != $::tkcon::OPT(exec)} { 906 interp delete $slave 907 } 908 destroy $PRIV(tabframe).cb[winfo name $con] 909 destroy $con 910} 911 912## ::tkcon::GarbageCollect - do various cleanup ops periodically to our setup 913## 914proc ::tkcon::GarbageCollect {} { 915 variable OPT 916 variable PRIV 917 918 foreach w $PRIV(tabs) { 919 if {[winfo exists $w]} { 920 ## Remove error tags that no longer span anything 921 ## Make sure the tag pattern matches the unique tag prefix 922 foreach tag [$w tag names] { 923 if {[string match _tag* $tag] 924 && ![llength [$w tag ranges $tag]]} { 925 $w tag delete $tag 926 } 927 } 928 } 929 } 930 if {$OPT(gc-delay)} { 931 after $OPT(gc-delay) ::tkcon::GarbageCollect 932 } 933} 934 935## ::tkcon::Eval - evaluates commands input into console window 936## This is the first stage of the evaluating commands in the console. 937## They need to be broken up into consituent commands (by ::tkcon::CmdSep) in 938## case a multiple commands were pasted in, then each is eval'ed (by 939## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed. 940# ARGS: w - console text widget 941# Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd 942## 943proc ::tkcon::Eval {w} { 944 set complete [CmdSep [CmdGet $w] cmds last] 945 $w mark set insert end-1c 946 $w insert end \n 947 if {[llength $cmds]} { 948 foreach c $cmds {EvalCmd $w $c} 949 $w insert insert $last {} 950 } elseif {$complete} { 951 EvalCmd $w $last 952 } 953 if {[winfo exists $w]} { 954 $w see insert 955 } 956} 957 958## ::tkcon::EvalCmd - evaluates a single command, adding it to history 959# ARGS: w - console text widget 960# cmd - the command to evaluate 961# Calls: ::tkcon::Prompt 962# Outputs: result of command to stdout (or stderr if error occured) 963# Returns: next event number 964## 965proc ::tkcon::EvalCmd {w cmd} { 966 variable OPT 967 variable PRIV 968 969 $w mark set output end 970 if {$cmd ne ""} { 971 set code 0 972 if {$OPT(subhistory)} { 973 set ev [EvalSlave history nextid] 974 incr ev -1 975 ## FIX: calcmode doesn't work with requesting history events 976 if {$cmd eq "!!"} { 977 set code [catch {EvalSlave history event $ev} cmd] 978 if {!$code} {$w insert output $cmd\n stdin} 979 } elseif {[regexp {^!(.+)$} $cmd dummy event]} { 980 ## Check last event because history event is broken 981 set code [catch {EvalSlave history event $ev} cmd] 982 if {!$code && ![string match ${event}* $cmd]} { 983 set code [catch {EvalSlave history event $event} cmd] 984 } 985 if {!$code} {$w insert output $cmd\n stdin} 986 } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { 987 set code [catch {EvalSlave history event $ev} cmd] 988 if {!$code} { 989 regsub -all -- $old $cmd $new cmd 990 $w insert output $cmd\n stdin 991 } 992 } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} { 993 AddSlaveHistory $cmd 994 set cmd $err 995 set code -1 996 } 997 } 998 if {$code} { 999 $w insert output $cmd\n stderr 1000 } else { 1001 ## We are about to evaluate the command, so move the limit 1002 ## mark to ensure that further <Return>s don't cause double 1003 ## evaluation of this command - for cases like the command 1004 ## has a vwait or something in it 1005 $w mark set limit end 1006 if {$OPT(nontcl) && ($PRIV(apptype) eq "interp")} { 1007 set code [catch {EvalSend $cmd} res] 1008 if {$code == 1} { 1009 set PRIV(errorInfo) "Non-Tcl errorInfo not available" 1010 } 1011 } elseif {$PRIV(apptype) eq "socket"} { 1012 set code [catch {EvalSocket $cmd} res] 1013 if {$code == 1} { 1014 set PRIV(errorInfo) "Socket-based errorInfo not available" 1015 } 1016 } else { 1017 set code [catch {EvalAttached $cmd} res] 1018 if {$code == 1} { 1019 if {[catch {EvalAttached [list set errorInfo]} err]} { 1020 set PRIV(errorInfo) "Error getting errorInfo:\n$err" 1021 } else { 1022 set PRIV(errorInfo) $err 1023 } 1024 } 1025 } 1026 if {![winfo exists $w]} { 1027 # early abort - must be a deleted tab 1028 return 1029 } 1030 AddSlaveHistory $cmd 1031 # Run any user defined result filter command. The command is 1032 # passed result code and data. 1033 if {[llength $OPT(resultfilter)]} { 1034 set cmd [linsert $OPT(resultfilter) end $code $res] 1035 if {[catch {EvalAttached $cmd} res2]} { 1036 $w insert output "Filter failed: $res2" stderr \n stdout 1037 } else { 1038 set res $res2 1039 } 1040 } 1041 catch {EvalAttached [list set _ $res]} 1042 set maxlen $OPT(maxlinelen) 1043 set trailer "" 1044 if {($maxlen > 0) && ([string length $res] > $maxlen)} { 1045 # If we exceed maximum desired output line length, truncate 1046 # the result and add "...+${num}b" in error coloring 1047 set trailer ...+[expr {[string length $res]-$maxlen}]b 1048 set res [string range $res 0 $maxlen] 1049 } 1050 if {$code} { 1051 if {$OPT(hoterrors)} { 1052 set tag [UniqueTag $w] 1053 $w insert output $res [list stderr $tag] \n$trailer stderr 1054 $w tag bind $tag <Enter> \ 1055 [list $w tag configure $tag -under 1] 1056 $w tag bind $tag <Leave> \ 1057 [list $w tag configure $tag -under 0] 1058 $w tag bind $tag <ButtonRelease-1> \ 1059 "if {!\[info exists tk::Priv(mouseMoved)\] || !\$tk::Priv(mouseMoved)} \ 1060 {[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}" 1061 } else { 1062 $w insert output $res\n$trailer stderr 1063 } 1064 } elseif {$res ne ""} { 1065 $w insert output $res stdout $trailer stderr \n stdout 1066 } 1067 } 1068 } 1069 Prompt 1070 set PRIV(event) [EvalSlave history nextid] 1071} 1072 1073## ::tkcon::EvalSlave - evaluates the args in the associated slave 1074## args should be passed to this procedure like they would be at 1075## the command line (not like to 'eval'). 1076# ARGS: args - the command and args to evaluate 1077## 1078proc ::tkcon::EvalSlave args { 1079 interp eval $::tkcon::OPT(exec) $args 1080} 1081 1082## ::tkcon::EvalOther - evaluate a command in a foreign interp or slave 1083## without attaching to it. No check for existence is made. 1084# ARGS: app - interp/slave name 1085# type - (slave|interp) 1086## 1087proc ::tkcon::EvalOther { app type args } { 1088 if {$type eq "slave"} { 1089 return [Slave $app $args] 1090 } else { 1091 return [uplevel 1 ::send::send [list $app] $args] 1092 } 1093} 1094 1095## ::tkcon::AddSlaveHistory - 1096## Command is added to history only if different from previous command. 1097## This also doesn't cause the history id to be incremented, although the 1098## command will be evaluated. 1099# ARGS: cmd - command to add 1100## 1101proc ::tkcon::AddSlaveHistory cmd { 1102 set ev [EvalSlave history nextid] 1103 incr ev -1 1104 set code [catch {EvalSlave history event $ev} lastCmd] 1105 if {$code || $cmd ne $lastCmd} { 1106 EvalSlave history add $cmd 1107 } 1108} 1109 1110## ::tkcon::EvalSend - sends the args to the attached interpreter 1111## Varies from 'send' by determining whether attachment is dead 1112## when an error is received 1113# ARGS: cmd - the command string to send across 1114# Returns: the result of the command 1115## 1116proc ::tkcon::EvalSend cmd { 1117 variable OPT 1118 variable PRIV 1119 1120 if {$PRIV(deadapp)} { 1121 if {[lsearch -exact [::send::interps] $PRIV(app)]<0} { 1122 return 1123 } else { 1124 set PRIV(appname) [string range $PRIV(appname) 5 end] 1125 set PRIV(deadapp) 0 1126 Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)] 1127 } 1128 } 1129 set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result] 1130 if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} { 1131 ## Interpreter disappeared 1132 if {($OPT(dead) ne "leave") && 1133 (($OPT(dead) eq "ignore") || 1134 [tk_messageBox -title "Dead Attachment" -type yesno \ 1135 -icon info -message \ 1136 "\"$PRIV(app)\" appears to have died.\ 1137 \nReturn to primary slave interpreter?"] eq "no")} { 1138 set PRIV(appname) "DEAD:$PRIV(appname)" 1139 set PRIV(deadapp) 1 1140 } else { 1141 set err "Attached Tk interpreter \"$PRIV(app)\" died." 1142 Attach {} 1143 set PRIV(deadapp) 0 1144 EvalSlave set errorInfo $err 1145 } 1146 Prompt \n [CmdGet $PRIV(console)] 1147 } 1148 return -code $code $result 1149} 1150 1151## ::tkcon::EvalSocket - sends the string to an interpreter attached via 1152## a tcp/ip socket 1153## 1154## In the EvalSocket case, ::tkcon::PRIV(app) is the socket id 1155## 1156## Must determine whether socket is dead when an error is received 1157# ARGS: cmd - the data string to send across 1158# Returns: the result of the command 1159## 1160proc ::tkcon::EvalSocket cmd { 1161 variable OPT 1162 variable PRIV 1163 global tcl_version 1164 1165 if {$PRIV(deadapp)} { 1166 if {![info exists PRIV(app)] || \ 1167 [catch {eof $PRIV(app)} eof] || $eof} { 1168 return 1169 } else { 1170 set PRIV(appname) [string range $PRIV(appname) 5 end] 1171 set PRIV(deadapp) 0 1172 Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)] 1173 } 1174 } 1175 # Sockets get \'s interpreted, so that users can 1176 # send things like \n\r or explicit hex values 1177 set cmd [subst -novariables -nocommands $cmd] 1178 #puts [list $PRIV(app) $cmd] 1179 set code [catch {puts $PRIV(app) $cmd ; flush $PRIV(app)} result] 1180 if {$code && [eof $PRIV(app)]} { 1181 ## Interpreter died or disappeared 1182 puts "$code eof [eof $PRIV(app)]" 1183 EvalSocketClosed $PRIV(app) 1184 } 1185 return -code $code $result 1186} 1187 1188## ::tkcon::EvalSocketEvent - fileevent command for an interpreter attached 1189## via a tcp/ip socket 1190## Must determine whether socket is dead when an error is received 1191# ARGS: args - the args to send across 1192# Returns: the result of the command 1193## 1194proc ::tkcon::EvalSocketEvent {sock} { 1195 variable PRIV 1196 1197 if {[gets $sock line] == -1} { 1198 if {[eof $sock]} { 1199 EvalSocketClosed $sock 1200 } 1201 return 1202 } 1203 puts $line 1204} 1205 1206## ::tkcon::EvalSocketClosed - takes care of handling a closed eval socket 1207## 1208# ARGS: args - the args to send across 1209# Returns: the result of the command 1210## 1211proc ::tkcon::EvalSocketClosed {sock} { 1212 variable OPT 1213 variable PRIV 1214 1215 catch {close $sock} 1216 if {$sock ne $PRIV(app)} { 1217 # If we are not still attached to that socket, just return. 1218 # Might be nice to tell the user the socket closed ... 1219 return 1220 } 1221 if {$OPT(dead) ne "leave" && 1222 ($OPT(dead) eq "ignore" || 1223 [tk_messageBox -title "Dead Attachment" -type yesno \ 1224 -icon question \ 1225 -message "\"$PRIV(app)\" appears to have died.\ 1226 \nReturn to primary slave interpreter?"] eq "no")} { 1227 set PRIV(appname) "DEAD:$PRIV(appname)" 1228 set PRIV(deadapp) 1 1229 } else { 1230 set err "Attached Tk interpreter \"$PRIV(app)\" died." 1231 Attach {} 1232 set PRIV(deadapp) 0 1233 EvalSlave set errorInfo $err 1234 } 1235 Prompt \n [CmdGet $PRIV(console)] 1236} 1237 1238## ::tkcon::EvalNamespace - evaluates the args in a particular namespace 1239## This is an override for ::tkcon::EvalAttached for when the user wants 1240## to attach to a particular namespace of the attached interp 1241# ARGS: attached 1242# namespace the namespace to evaluate in 1243# args the args to evaluate 1244# RETURNS: the result of the command 1245## 1246proc ::tkcon::EvalNamespace { attached namespace args } { 1247 if {[llength $args]} { 1248 uplevel \#0 $attached \ 1249 [list [concat [list namespace eval $namespace] $args]] 1250 } 1251} 1252 1253 1254## ::tkcon::Namespaces - return all the namespaces descendent from $ns 1255## 1256# 1257## 1258proc ::tkcon::Namespaces {{ns ::} {l {}}} { 1259 if {$ns ne ""} { lappend l $ns } 1260 foreach i [EvalAttached [list namespace children $ns]] { 1261 set l [Namespaces $i $l] 1262 } 1263 return $l 1264} 1265 1266## ::tkcon::CmdGet - gets the current command from the console widget 1267# ARGS: w - console text widget 1268# Returns: text which compromises current command line 1269## 1270proc ::tkcon::CmdGet w { 1271 if {![llength [$w tag nextrange prompt limit end]]} { 1272 $w tag add stdin limit end-1c 1273 return [$w get limit end-1c] 1274 } 1275} 1276 1277## ::tkcon::CmdSep - separates multiple commands into a list and remainder 1278# ARGS: cmd - (possible) multiple command to separate 1279# list - varname for the list of commands that were separated. 1280# last - varname of any remainder (like an incomplete final command). 1281# If there is only one command, it's placed in this var. 1282# Returns: constituent command info in varnames specified by list & rmd. 1283## 1284proc ::tkcon::CmdSep {cmd list last} { 1285 upvar 1 $list cmds $last inc 1286 set inc {} 1287 set cmds {} 1288 foreach c [split [string trimleft $cmd] \n] { 1289 if {$inc ne ""} { 1290 append inc \n$c 1291 } else { 1292 append inc [string trimleft $c] 1293 } 1294 if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { 1295 if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} 1296 set inc {} 1297 } 1298 } 1299 set i [string equal $inc {}] 1300 if {$i && $cmds ne "" && ![string match *\n $cmd]} { 1301 set inc [lindex $cmds end] 1302 set cmds [lreplace $cmds end end] 1303 } 1304 return $i 1305} 1306 1307## ::tkcon::CmdSplit - splits multiple commands into a list 1308# ARGS: cmd - (possible) multiple command to separate 1309# Returns: constituent commands in a list 1310## 1311proc ::tkcon::CmdSplit {cmd} { 1312 set inc {} 1313 set cmds {} 1314 foreach cmd [split [string trimleft $cmd] \n] { 1315 if {$inc ne ""} { 1316 append inc \n$cmd 1317 } else { 1318 append inc [string trimleft $cmd] 1319 } 1320 if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { 1321 #set inc [string trimright $inc] 1322 if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} 1323 set inc {} 1324 } 1325 } 1326 if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} 1327 return $cmds 1328} 1329 1330## ::tkcon::UniqueTag - creates a uniquely named tag, reusing names 1331## Called by ::tkcon::EvalCmd 1332# ARGS: w - text widget 1333# Outputs: tag name guaranteed unique in the widget 1334## 1335proc ::tkcon::UniqueTag {w} { 1336 set tags [$w tag names] 1337 set idx 0 1338 while {[lsearch -exact $tags _tag[incr idx]] != -1} {} 1339 return _tag$idx 1340} 1341 1342## ::tkcon::ConstrainBuffer - This limits the amount of data in the text widget 1343## Called by ::tkcon::Prompt and in tkcon proc buffer/console switch cases 1344# ARGS: w - console text widget 1345# size - # of lines to constrain to 1346# Outputs: may delete data in console widget 1347## 1348proc ::tkcon::ConstrainBuffer {w size} { 1349 if {$size && ([$w index end] > $size)} { 1350 $w delete 1.0 [expr {int([$w index end])-$size}].0 1351 } 1352} 1353 1354## ::tkcon::Prompt - displays the prompt in the console widget 1355# ARGS: w - console text widget 1356# Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console 1357## 1358proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} { 1359 variable OPT 1360 variable PRIV 1361 1362 set w $PRIV(console) 1363 if {![winfo exists $w]} { return } 1364 if {$pre ne ""} { $w insert end $pre stdout } 1365 set i [$w index end-1c] 1366 if {!$OPT(showstatusbar)} { 1367 if {$PRIV(appname) ne ""} { 1368 $w insert end ">$PRIV(appname)< " prompt 1369 } 1370 if {$PRIV(namesp) ne "::"} { 1371 $w insert end "<$PRIV(namesp)> " prompt 1372 } 1373 } 1374 if {$prompt ne ""} { 1375 $w insert end $prompt prompt 1376 } else { 1377 $w insert end [EvalSlave subst $OPT(prompt1)] prompt 1378 } 1379 $w mark set output $i 1380 $w mark set insert end 1381 $w mark set limit insert 1382 $w mark gravity limit left 1383 if {$post ne ""} { $w insert end $post stdin } 1384 ConstrainBuffer $w $OPT(buffer) 1385 set ::tkcon::PRIV(StatusCursor) [$w index insert] 1386 $w see end 1387} 1388proc ::tkcon::RePrompt {{pre {}} {post {}} {prompt {}}} { 1389 # same as prompt, but does nothing for those actions where we 1390 # only wanted to refresh the prompt on attach change when the 1391 # statusbar is showing (which carries that info instead) 1392 variable OPT 1393 if {!$OPT(showstatusbar)} { 1394 Prompt $pre $post $prompt 1395 } 1396} 1397 1398## ::tkcon::About - gives about info for tkcon 1399## 1400proc ::tkcon::About {} { 1401 variable OPT 1402 variable PRIV 1403 variable COLOR 1404 1405 set w $PRIV(base).about 1406 if {![winfo exists $w]} { 1407 global tk_patchLevel tcl_patchLevel tcl_version 1408 toplevel $w 1409 wm withdraw $w 1410 wm transient $w $PRIV(root) 1411 wm group $w $PRIV(root) 1412 catch {wm attributes $w -type dialog} 1413 wm title $w "About tkcon v$PRIV(version)" 1414 wm resizable $w 0 0 1415 button $w.b -text Dismiss -command [list wm withdraw $w] 1416 text $w.text -height 9 -width 60 \ 1417 -foreground $COLOR(stdin) \ 1418 -background $COLOR(bg) \ 1419 -font $OPT(font) -borderwidth 1 -highlightthickness 0 1420 grid $w.text -sticky news 1421 grid $w.b -sticky se -padx 6 -pady 4 1422 $w.text tag config center -justify center 1423 $w.text tag config title -justify center -font {Courier -18 bold} 1424 # strip down the RCS info displayed in the about box 1425 regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS 1426 $w.text insert 1.0 "About tkcon v$PRIV(version)" title \ 1427 "\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\ 1428 \nRelease Info: v$PRIV(version), CVS v$RCS\ 1429 \nDocumentation available at:\n$PRIV(docs)\ 1430 \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center 1431 $w.text config -state disabled 1432 bind $w <Escape> [list destroy $w] 1433 } 1434 wm deiconify $w 1435} 1436 1437## ::tkcon::InitMenus - inits the menubar and popup for the console 1438# ARGS: w - console text widget 1439## 1440proc ::tkcon::InitMenus {w title} { 1441 variable OPT 1442 variable PRIV 1443 variable COLOR 1444 global tcl_platform 1445 1446 if {[catch {menu $w.pop}]} { 1447 label $w.label -text "Menus not available in plugin mode" 1448 grid $w.label -sticky ew 1449 return 1450 } 1451 menu $w.context -disabledforeground $COLOR(disabled) 1452 set PRIV(context) $w.context 1453 set PRIV(popup) $w.pop 1454 1455 proc MenuButton {w m l} { 1456 $w add cascade -label $m -underline 0 -menu $w.$l 1457 return $w.$l 1458 } 1459 proc MenuConfigure {m l args} { 1460 variable PRIV 1461 eval [list $PRIV(menubar).[string tolower $m] entryconfigure $l] $args 1462 eval [list $PRIV(popup).[string tolower $m] entryconfigure $l] $args 1463 } 1464 1465 foreach m [list File Console Edit Interp Prefs History Help] { 1466 set l [string tolower $m] 1467 MenuButton $w $m $l 1468 $w.pop add cascade -label $m -underline 0 -menu $w.pop.$l 1469 } 1470 1471 ## File Menu 1472 ## 1473 foreach m [list [menu $w.file -disabledforeground $COLOR(disabled)] \ 1474 [menu $w.pop.file -disabledforeground $COLOR(disabled)]] { 1475 $m add command -label "Load File" -underline 0 -command ::tkcon::Load 1476 $m add cascade -label "Save ..." -underline 0 -menu $m.save 1477 $m add separator 1478 $m add command -label "Quit" -underline 0 -accel Ctrl-q -command exit 1479 1480 ## Save Menu 1481 ## 1482 set s $m.save 1483 menu $s -disabledforeground $COLOR(disabled) 1484 $s add command -label "All" -underline 0 \ 1485 -command {::tkcon::Save {} all} 1486 $s add command -label "History" -underline 0 \ 1487 -command {::tkcon::Save {} history} 1488 $s add command -label "Stdin" -underline 3 \ 1489 -command {::tkcon::Save {} stdin} 1490 $s add command -label "Stdout" -underline 3 \ 1491 -command {::tkcon::Save {} stdout} 1492 $s add command -label "Stderr" -underline 3 \ 1493 -command {::tkcon::Save {} stderr} 1494 } 1495 1496 ## Console Menu 1497 ## 1498 foreach m [list [menu $w.console -disabledfore $COLOR(disabled)] \ 1499 [menu $w.pop.console -disabledfore $COLOR(disabled)]] { 1500 $m add command -label "$title Console" -state disabled 1501 $m add command -label "New Console" -underline 0 -accel Ctrl-N \ 1502 -command ::tkcon::New 1503 $m add command -label "New Tab" -underline 4 -accel Ctrl-T \ 1504 -command ::tkcon::NewTab 1505 $m add command -label "Delete Tab" -underline 0 \ 1506 -command ::tkcon::DeleteTab -state disabled 1507 $m add command -label "Close Console" -underline 0 -accel Ctrl-w \ 1508 -command ::tkcon::Destroy 1509 $m add command -label "Clear Console" -underline 1 -accel Ctrl-l \ 1510 -command { clear; ::tkcon::Prompt } 1511 if {[tk windowingsystem] eq "x11"} { 1512 $m add separator 1513 $m add command -label "Make Xauth Secure" -und 5 \ 1514 -command ::tkcon::XauthSecure 1515 } 1516 $m add separator 1517 $m add cascade -label "Attach To ..." -underline 0 -menu $m.attach 1518 1519 ## Attach Console Menu 1520 ## 1521 set sub [menu $m.attach -disabledforeground $COLOR(disabled)] 1522 $sub add cascade -label "Interpreter" -underline 0 -menu $sub.apps 1523 $sub add cascade -label "Namespace" -underline 0 -menu $sub.name 1524 1525 ## Attach Console Menu 1526 ## 1527 menu $sub.apps -disabledforeground $COLOR(disabled) \ 1528 -postcommand [list ::tkcon::AttachMenu $sub.apps] 1529 1530 ## Attach Namespace Menu 1531 ## 1532 menu $sub.name -disabledforeground $COLOR(disabled) \ 1533 -postcommand [list ::tkcon::NamespaceMenu $sub.name] 1534 1535 ## Attach Socket Menu 1536 ## 1537 $sub add cascade -label "Socket" -underline 0 -menu $sub.sock 1538 menu $sub.sock -disabledforeground $COLOR(disabled) \ 1539 -postcommand [list ::tkcon::SocketMenu $sub.sock] 1540 1541 if {[tk windowingsystem] eq "x11"} { 1542 ## Attach Display Menu 1543 ## 1544 $sub add cascade -label "Display" -underline 0 -menu $sub.disp 1545 menu $sub.disp -disabledforeground $COLOR(disabled) \ 1546 -postcommand [list ::tkcon::DisplayMenu $sub.disp] 1547 } 1548 } 1549 1550 ## Edit Menu 1551 ## 1552 set text $PRIV(console) 1553 foreach m [list [menu $w.edit] [menu $w.pop.edit]] { 1554 $m add command -label "Cut" -underline 2 -accel Ctrl-x \ 1555 -command [list ::tkcon::Cut $text] 1556 $m add command -label "Copy" -underline 0 -accel Ctrl-c \ 1557 -command [list ::tkcon::Copy $text] 1558 $m add command -label "Paste" -underline 0 -accel Ctrl-v \ 1559 -command [list ::tkcon::Paste $text] 1560 $m add separator 1561 $m add command -label "Find" -underline 0 -accel Ctrl-F \ 1562 -command [list ::tkcon::FindBox $text] 1563 } 1564 1565 ## Interp Menu 1566 ## 1567 foreach m [list $w.interp $w.pop.interp] { 1568 menu $m -disabledforeground $COLOR(disabled) \ 1569 -postcommand [list ::tkcon::InterpMenu $m] 1570 } 1571 1572 ## Prefs Menu 1573 ## 1574 foreach m [list [menu $w.prefs] [menu $w.pop.prefs]] { 1575 $m add check -label "Brace Highlighting" \ 1576 -underline 0 -variable ::tkcon::OPT(lightbrace) 1577 $m add check -label "Command Highlighting" \ 1578 -underline 0 -variable ::tkcon::OPT(lightcmd) 1579 $m add check -label "History Substitution" \ 1580 -underline 0 -variable ::tkcon::OPT(subhistory) 1581 $m add check -label "Hot Errors" \ 1582 -underline 4 -variable ::tkcon::OPT(hoterrors) 1583 $m add check -label "Non-Tcl Attachments" \ 1584 -underline 0 -variable ::tkcon::OPT(nontcl) 1585 $m add check -label "Calculator Mode" \ 1586 -underline 1 -variable ::tkcon::OPT(calcmode) 1587 $m add check -label "Show Multiple Matches" \ 1588 -underline 0 -variable ::tkcon::OPT(showmultiple) 1589 $m add check -label "Show Menubar" \ 1590 -underline 5 -variable ::tkcon::OPT(showmenu) \ 1591 -command {$::tkcon::PRIV(root) configure -menu [expr \ 1592 {$::tkcon::OPT(showmenu) ? $::tkcon::PRIV(menubar) : {}}]} 1593 $m add check -label "Show Statusbar" \ 1594 -underline 5 -variable ::tkcon::OPT(showstatusbar) \ 1595 -command { 1596 if {$::tkcon::OPT(showstatusbar)} { 1597 grid $::tkcon::PRIV(statusbar) 1598 } else { grid remove $::tkcon::PRIV(statusbar) } 1599 } 1600 $m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll 1601 1602 ## Scrollbar Menu 1603 ## 1604 set m [menu $m.scroll] 1605 $m add radio -label "Left" -value left \ 1606 -variable ::tkcon::OPT(scrollypos) \ 1607 -command { grid configure $::tkcon::PRIV(scrolly) -column 0 } 1608 $m add radio -label "Right" -value right \ 1609 -variable ::tkcon::OPT(scrollypos) \ 1610 -command { grid configure $::tkcon::PRIV(scrolly) -column 2 } 1611 } 1612 1613 ## History Menu 1614 ## 1615 foreach m [list $w.history $w.pop.history] { 1616 menu $m -disabledforeground $COLOR(disabled) \ 1617 -postcommand [list ::tkcon::HistoryMenu $m] 1618 } 1619 1620 ## Help Menu 1621 ## 1622 foreach m [list [menu $w.help] [menu $w.pop.help]] { 1623 $m add command -label "About " -underline 0 -accel Ctrl-A \ 1624 -command ::tkcon::About 1625 $m add command -label "Retrieve Latest Version" -underline 0 \ 1626 -command ::tkcon::Retrieve 1627 if {![catch {package require Tcl} ver]} { 1628 set cmd "" 1629 if {$tcl_platform(platform) == "windows"} { 1630 package require registry 1631 set ver [join [lrange [split $ver .] 0 3] .] 1632 set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl} 1633 if {![catch {registry get "$key\\$ver\\Help" ""} help] 1634 && [file exists $help]} { 1635 set cmd [list exec $::env(COMSPEC) /c start {} $help] 1636 } 1637 } elseif {$tcl_platform(os) == "Darwin"} { 1638 set ver [join [lrange [split $ver .] 0 1] .] 1639 set rsc "/System/Library/Frameworks/Tcl.framework/Versions/$ver/Resources" 1640 set help "$rsc/Documentation/Reference/Tcl/TclTOC.html" 1641 if {[file exists $help]} { 1642 set cmd [list exec open -b com.apple.Safari "file://$help"] 1643 } 1644 } elseif {$tcl_platform(platform) == "unix"} { 1645 set help [file dirname [info nameofexe]] 1646 append help /../html/index.html 1647 if {[file exists $help]} { 1648 set cmd [list puts "Start $help"] 1649 } 1650 } 1651 if {$cmd != ""} { 1652 $m add separator 1653 $m add command -label "Tcl Help" -underline 10 \ 1654 -command $cmd 1655 } 1656 } 1657 } 1658} 1659 1660## ::tkcon::HistoryMenu - dynamically build the menu for attached interpreters 1661## 1662# ARGS: m - menu widget 1663## 1664proc ::tkcon::HistoryMenu m { 1665 variable PRIV 1666 1667 if {![winfo exists $m]} return 1668 set id [EvalSlave history nextid] 1669 if {$PRIV(histid)==$id} return 1670 set PRIV(histid) $id 1671 $m delete 0 end 1672 while {($id>1) && ($id>$PRIV(histid)-10) && \ 1673 ![catch {EvalSlave history event [incr id -1]} tmp]} { 1674 set lbl $tmp 1675 if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... } 1676 $m add command -label "$id: $lbl" -command " 1677 $::tkcon::PRIV(console) delete limit end 1678 $::tkcon::PRIV(console) insert limit [list $tmp] 1679 $::tkcon::PRIV(console) see end 1680 ::tkcon::Eval $::tkcon::PRIV(console)" 1681 } 1682} 1683 1684## ::tkcon::InterpMenu - dynamically build the menu for attached interpreters 1685## 1686# ARGS: w - menu widget 1687## 1688proc ::tkcon::InterpMenu w { 1689 variable OPT 1690 variable PRIV 1691 variable COLOR 1692 1693 if {![winfo exists $w]} return 1694 $w delete 0 end 1695 foreach {app type} [Attach] break 1696 $w add command -label "[string toupper $type]: $app" -state disabled 1697 if {($OPT(nontcl) && $type eq "interp") || $PRIV(deadapp)} { 1698 $w add separator 1699 $w add command -state disabled -label "Communication disabled to" 1700 $w add command -state disabled -label "dead or non-Tcl interps" 1701 return 1702 } 1703 1704 ## Show Last Error 1705 ## 1706 $w add separator 1707 $w add command -label "Show Last Error" \ 1708 -command [list tkcon error $app $type] 1709 1710 ## Packages Cascaded Menu 1711 ## 1712 $w add separator 1713 $w add command -label "Manage Packages" -underline 0 \ 1714 -command [list ::tkcon::InterpPkgs $app $type] 1715 1716 ## State Checkpoint/Revert 1717 ## 1718 $w add separator 1719 $w add command -label "Checkpoint State" \ 1720 -command [list ::tkcon::StateCheckpoint $app $type] 1721 $w add command -label "Revert State" \ 1722 -command [list ::tkcon::StateRevert $app $type] 1723 $w add command -label "View State Change" \ 1724 -command [list ::tkcon::StateCompare $app $type] 1725 1726 ## Init Interp 1727 ## 1728 $w add separator 1729 $w add command -label "Send tkcon Commands" \ 1730 -command [list ::tkcon::InitInterp $app $type] 1731} 1732 1733## ::tkcon::PkgMenu - fill in in the applications sub-menu 1734## with a list of all the applications that currently exist. 1735## 1736proc ::tkcon::InterpPkgs {app type} { 1737 variable PRIV 1738 1739 set t $PRIV(base).interppkgs 1740 if {![winfo exists $t]} { 1741 toplevel $t 1742 wm withdraw $t 1743 wm title $t "$app Packages" 1744 wm transient $t $PRIV(root) 1745 wm group $t $PRIV(root) 1746 catch {wm attributes $t -type dialog} 1747 bind $t <Escape> [list destroy $t] 1748 1749 label $t.ll -text "Loadable:" -anchor w 1750 label $t.lr -text "Loaded:" -anchor w 1751 listbox $t.loadable -font tkconfixed -background white -borderwidth 1 \ 1752 -yscrollcommand [list $t.llsy set] -selectmode extended 1753 listbox $t.loaded -font tkconfixed -background white -borderwidth 1 \ 1754 -yscrollcommand [list $t.lrsy set] 1755 scrollbar $t.llsy -command [list $t.loadable yview] 1756 scrollbar $t.lrsy -command [list $t.loaded yview] 1757 button $t.load -borderwidth 1 -text ">>" \ 1758 -command [list ::tkcon::InterpPkgLoad $app $type $t.loadable] 1759 if {$::tcl_version >= 8.4} { 1760 $t.load configure -relief flat -overrelief raised 1761 } 1762 1763 set f [frame $t.btns] 1764 button $f.refresh -width 8 -text "Refresh" -command [info level 0] 1765 button $f.dismiss -width 8 -text "Dismiss" -command [list destroy $t] 1766 grid $f.refresh $f.dismiss -padx 4 -pady 3 -sticky ew 1767 1768 grid $t.ll x x $t.lr x -sticky ew 1769 grid $t.loadable $t.llsy $t.load $t.loaded $t.lrsy -sticky news 1770 grid $t.btns -sticky e -columnspan 5 1771 grid columnconfigure $t {0 3} -weight 1 1772 grid rowconfigure $t 1 -weight 1 1773 grid configure $t.load -sticky "" 1774 1775 bind $t.loadable <Double-1> "[list $t.load invoke]; break" 1776 } 1777 $t.loaded delete 0 end 1778 $t.loadable delete 0 end 1779 1780 # just in case stuff has been added to the auto_path 1781 # we have to make sure that the errorInfo doesn't get screwed up 1782 EvalAttached { 1783 set __tkcon_error $errorInfo 1784 catch {package require bogus-package-name} 1785 set errorInfo ${__tkcon_error} 1786 unset __tkcon_error 1787 } 1788 # get all packages loaded into current interp 1789 foreach pkg [EvalAttached [list info loaded {}]] { 1790 set pkg [lindex $pkg 1] 1791 set loaded($pkg) [package provide $pkg] 1792 } 1793 # get all package names currently visible 1794 foreach pkg [lremove [EvalAttached {package names}] Tcl] { 1795 set version [EvalAttached [list package provide $pkg]] 1796 if {$version ne ""} { 1797 set loaded($pkg) $version 1798 } elseif {![info exists loaded($pkg)]} { 1799 set loadable($pkg) package 1800 } 1801 } 1802 # get packages that are loaded in any interp 1803 foreach pkg [EvalAttached {info loaded}] { 1804 set pkg [lindex $pkg 1] 1805 if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { 1806 set loadable($pkg) load 1807 } 1808 } 1809 foreach pkg [lsort -dictionary [array names loadable]] { 1810 foreach v [EvalAttached [list package version $pkg]] { 1811 $t.loadable insert end [list $pkg $v "($loadable($pkg))"] 1812 } 1813 } 1814 foreach pkg [lsort -dictionary [array names loaded]] { 1815 $t.loaded insert end [list $pkg $loaded($pkg)] 1816 } 1817 1818 wm deiconify $t 1819 raise $t 1820} 1821 1822proc ::tkcon::InterpPkgLoad {app type lb} { 1823 # load the lb entry items into the interp 1824 foreach sel [$lb curselection] { 1825 foreach {pkg ver method} [$lb get $sel] { break } 1826 if {$method == "(package)"} { 1827 set code [catch {::tkcon::EvalOther $app $type \ 1828 package require $pkg $ver} msg] 1829 } elseif {$method == "(load)"} { 1830 set code [catch {::tkcon::EvalOther $app $type load {} $pkg} msg] 1831 } else { 1832 set code 1 1833 set msg "Incorrect entry in Loadable selection" 1834 } 1835 if {$code} { 1836 tk_messageBox -icon error -title "Error requiring $pkg" -type ok \ 1837 -message "Error requiring $pkg $ver:\n$msg\n$::errorInfo" 1838 } 1839 } 1840 # refresh package list 1841 InterpPkgs $app $type 1842} 1843 1844## ::tkcon::AttachMenu - fill in in the applications sub-menu 1845## with a list of all the applications that currently exist. 1846## 1847proc ::tkcon::AttachMenu m { 1848 variable OPT 1849 variable PRIV 1850 1851 array set interps [set tmp [Interps]] 1852 foreach {i j} $tmp { set tknames($j) {} } 1853 1854 $m delete 0 end 1855 set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} 1856 $m add radio -label {None (use local slave) } -accel Ctrl-1 \ 1857 -variable ::tkcon::PRIV(app) \ 1858 -value [concat $::tkcon::PRIV(name) $::tkcon::OPT(exec)] \ 1859 -command "::tkcon::Attach {}; $cmd" 1860 $m add separator 1861 $m add command -label "Foreign Tk Interpreters" -state disabled 1862 foreach i [lsort [lremove [::send::interps] [array names tknames]]] { 1863 $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \ 1864 -command "::tkcon::Attach [list $i] interp; $cmd" 1865 } 1866 $m add separator 1867 1868 $m add command -label "tkcon Interpreters" -state disabled 1869 foreach i [lsort [array names interps]] { 1870 if {$interps($i) eq ""} { set interps($i) "no Tk" } 1871 if {[regexp {^Slave[0-9]+} $i]} { 1872 set opts [list -label "$i ($interps($i))" \ 1873 -variable ::tkcon::PRIV(app) -value $i \ 1874 -command "::tkcon::Attach [list $i] slave; $cmd"] 1875 if {$PRIV(name) eq $i} { 1876 append opts " -accel Ctrl-2" 1877 } 1878 eval $m add radio $opts 1879 } else { 1880 set name [concat Main $i] 1881 if {$name eq "Main"} { 1882 $m add radio -label "$name ($interps($i))" -accel Ctrl-3 \ 1883 -variable ::tkcon::PRIV(app) -value Main \ 1884 -command "::tkcon::Attach [list $name] slave; $cmd" 1885 } else { 1886 $m add radio -label "$name ($interps($i))" \ 1887 -variable ::tkcon::PRIV(app) -value $i \ 1888 -command "::tkcon::Attach [list $name] slave; $cmd" 1889 } 1890 } 1891 } 1892} 1893 1894## Displays Cascaded Menu 1895## 1896proc ::tkcon::DisplayMenu m { 1897 $m delete 0 end 1898 set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} 1899 1900 $m add command -label "New Display" -command ::tkcon::NewDisplay 1901 foreach disp [Display] { 1902 $m add separator 1903 $m add command -label $disp -state disabled 1904 set res [Display $disp] 1905 set win [lindex $res 0] 1906 foreach i [lsort [lindex $res 1]] { 1907 $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \ 1908 -command "::tkcon::Attach [list $i] [list dpy:$win]; $cmd" 1909 } 1910 } 1911} 1912 1913## Sockets Cascaded Menu 1914## 1915proc ::tkcon::SocketMenu m { 1916 $m delete 0 end 1917 set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} 1918 1919 $m add command -label "Create Connection" \ 1920 -command "::tkcon::NewSocket; $cmd" 1921 foreach sock [file channels sock*] { 1922 $m add radio -label $sock -variable ::tkcon::PRIV(app) -value $sock \ 1923 -command "::tkcon::Attach $sock socket; $cmd" 1924 } 1925} 1926 1927## Namepaces Cascaded Menu 1928## 1929proc ::tkcon::NamespaceMenu m { 1930 variable PRIV 1931 variable OPT 1932 1933 $m delete 0 end 1934 if {($PRIV(deadapp) || $PRIV(apptype) eq "socket" || \ 1935 ($OPT(nontcl) && $PRIV(apptype) eq "interp"))} { 1936 $m add command -label "No Namespaces" -state disabled 1937 return 1938 } 1939 1940 ## Same command as for ::tkcon::AttachMenu items 1941 set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} 1942 1943 set names [lsort [Namespaces ::]] 1944 if {[llength $names] > $OPT(maxmenu)} { 1945 $m add command -label "Attached to $PRIV(namesp)" -state disabled 1946 $m add command -label "List Namespaces" \ 1947 -command [list ::tkcon::NamespacesList $names] 1948 } else { 1949 foreach i $names { 1950 if {$i eq "::"} { 1951 $m add radio -label "Main" -value $i \ 1952 -variable ::tkcon::PRIV(namesp) \ 1953 -command "::tkcon::AttachNamespace [list $i]; $cmd" 1954 } else { 1955 $m add radio -label $i -value $i \ 1956 -variable ::tkcon::PRIV(namesp) \ 1957 -command "::tkcon::AttachNamespace [list $i]; $cmd" 1958 } 1959 } 1960 } 1961} 1962 1963## Namepaces List 1964## 1965proc ::tkcon::NamespacesList {names} { 1966 variable PRIV 1967 1968 set f $PRIV(base).namespaces 1969 catch {destroy $f} 1970 toplevel $f 1971 catch {wm attributes $f -type dialog} 1972 listbox $f.names -width 30 -height 15 -selectmode single \ 1973 -yscrollcommand [list $f.scrollv set] \ 1974 -xscrollcommand [list $f.scrollh set] \ 1975 -background white -borderwidth 1 1976 scrollbar $f.scrollv -command [list $f.names yview] 1977 scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal 1978 frame $f.buttons 1979 button $f.cancel -text "Cancel" -command [list destroy $f] 1980 1981 grid $f.names $f.scrollv -sticky nesw 1982 grid $f.scrollh -sticky ew 1983 grid $f.buttons -sticky nesw 1984 grid $f.cancel -in $f.buttons -pady 6 1985 1986 grid columnconfigure $f 0 -weight 1 1987 grid rowconfigure $f 0 -weight 1 1988 #fill the listbox 1989 foreach i $names { 1990 if {$i eq "::"} { 1991 $f.names insert 0 Main 1992 } else { 1993 $f.names insert end $i 1994 } 1995 } 1996 #Bindings 1997 bind $f.names <Double-1> { 1998 ## Catch in case the namespace disappeared on us 1999 catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] } 2000 ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] 2001 destroy [winfo toplevel %W] 2002 } 2003} 2004 2005# ::tkcon::XauthSecure -- 2006# 2007# This removes all the names in the xhost list, and secures 2008# the display for Tk send commands. Of course, this prevents 2009# what might have been otherwise allowable X connections 2010# 2011# Arguments: 2012# none 2013# Results: 2014# Returns nothing 2015# 2016proc ::tkcon::XauthSecure {} { 2017 global tcl_platform 2018 2019 if {[tk windowingsystem] ne "x11"} { 2020 # This makes no sense outside of Unix 2021 return 2022 } 2023 set hosts [exec xhost] 2024 # the first line is info only 2025 foreach host [lrange [split $hosts \n] 1 end] { 2026 exec xhost -$host 2027 } 2028 exec xhost - 2029 tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info 2030} 2031 2032## ::tkcon::FindBox - creates minimal dialog interface to ::tkcon::Find 2033# ARGS: w - text widget 2034# str - optional seed string for ::tkcon::PRIV(find) 2035## 2036proc ::tkcon::FindBox {w {str {}}} { 2037 variable PRIV 2038 2039 set base $PRIV(base).find 2040 if {![winfo exists $base]} { 2041 toplevel $base 2042 wm withdraw $base 2043 catch {wm attributes $base -type dialog} 2044 wm title $base "tkcon Find" 2045 2046 pack [frame $base.f] -fill x -expand 1 2047 label $base.f.l -text "Find:" 2048 entry $base.f.e -textvariable ::tkcon::PRIV(find) 2049 pack [frame $base.opt] -fill x 2050 checkbutton $base.opt.c -text "Case Sensitive" \ 2051 -variable ::tkcon::PRIV(find,case) 2052 checkbutton $base.opt.r -text "Use Regexp" \ 2053 -variable ::tkcon::PRIV(find,reg) 2054 pack $base.f.l -side left 2055 pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 2056 pack [frame $base.sep -borderwidth 2 -relief sunken -height 4] -fill x 2057 pack [frame $base.btn] -fill both 2058 button $base.btn.fnd -text "Find" -width 6 2059 button $base.btn.clr -text "Clear" -width 6 2060 button $base.btn.dis -text "Dismiss" -width 6 2061 eval pack [winfo children $base.btn] -padx 4 -pady 2 \ 2062 -side left -fill both 2063 2064 focus $base.f.e 2065 2066 bind $base.f.e <Return> [list $base.btn.fnd invoke] 2067 bind $base.f.e <Escape> [list $base.btn.dis invoke] 2068 } 2069 $base.btn.fnd config -command "::tkcon::Find [list $w] \$::tkcon::PRIV(find) \ 2070 -case \$::tkcon::PRIV(find,case) -reg \$::tkcon::PRIV(find,reg)" 2071 $base.btn.clr config -command " 2072 [list $w] tag remove find 1.0 end 2073 set ::tkcon::PRIV(find) {} 2074 " 2075 $base.btn.dis config -command " 2076 [list $w] tag remove find 1.0 end 2077 wm withdraw [list $base] 2078 " 2079 if {$str ne ""} { 2080 set PRIV(find) $str 2081 $base.btn.fnd invoke 2082 } 2083 2084 if {[wm state $base] ne "normal"} { 2085 wm deiconify $base 2086 } else { raise $base } 2087 $base.f.e select range 0 end 2088} 2089 2090## ::tkcon::Find - searches in text widget $w for $str and highlights it 2091## If $str is empty, it just deletes any highlighting 2092# ARGS: w - text widget 2093# str - string to search for 2094# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 2095# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 2096## 2097proc ::tkcon::Find {w str args} { 2098 $w tag remove find 1.0 end 2099 set truth {^(1|yes|true|on)$} 2100 set opts {} 2101 foreach {key val} $args { 2102 switch -glob -- $key { 2103 -c* { if {[regexp -nocase $truth $val]} { set case 1 } } 2104 -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } } 2105 default { return -code error "Unknown option $key" } 2106 } 2107 } 2108 if {![info exists case]} { lappend opts -nocase } 2109 if {$str eq ""} { return } 2110 $w mark set findmark 1.0 2111 while {[set ix [eval $w search $opts -count numc -- \ 2112 [list $str] findmark end]] ne ""} { 2113 $w tag add find $ix ${ix}+${numc}c 2114 $w mark set findmark ${ix}+1c 2115 } 2116 $w tag configure find -background $::tkcon::COLOR(blink) 2117 catch {$w see find.first} 2118 return [expr {[llength [$w tag ranges find]]/2}] 2119} 2120 2121## ::tkcon::Attach - called to attach tkcon to an interpreter 2122# ARGS: name - application name to which tkcon sends commands 2123# This is either a slave interperter name or tk appname. 2124# type - (slave|interp) type of interpreter we're attaching to 2125# slave means it's a tkcon interpreter 2126# interp means we'll need to 'send' to it. 2127# Results: ::tkcon::EvalAttached is recreated to evaluate in the 2128# appropriate interpreter 2129## 2130proc ::tkcon::Attach {{name <NONE>} {type slave} {ns {}}} { 2131 variable PRIV 2132 variable OPT 2133 variable ATTACH 2134 2135 if {[llength [info level 0]] == 1} { 2136 # no args were specified, return the attach info instead 2137 return [AttachId] 2138 } 2139 set path [concat $PRIV(name) $OPT(exec)] 2140 2141 set PRIV(displayWin) . 2142 if {$type eq "namespace"} { 2143 return [uplevel 1 ::tkcon::AttachNamespace $name] 2144 } elseif {[string match dpy:* $type]} { 2145 set PRIV(displayWin) [string range $type 4 end] 2146 } elseif {[string match sock* $type]} { 2147 global tcl_version 2148 if {[catch {eof $name} res]} { 2149 return -code error "No known channel \"$name\"" 2150 } elseif {$res} { 2151 catch {close $name} 2152 return -code error "Channel \"$name\" returned EOF" 2153 } 2154 set app $name 2155 set type socket 2156 } elseif {$name ne ""} { 2157 array set interps [Interps] 2158 if {[string match {[Mm]ain} [lindex $name 0]]} { 2159 set name [lrange $name 1 end] 2160 } 2161 if {$name eq $path} { 2162 set name {} 2163 set app $path 2164 set type slave 2165 } elseif {[info exists interps($name)]} { 2166 if {$name eq ""} { set name Main; set app Main } 2167 set type slave 2168 } elseif {[interp exists $name]} { 2169 set name [concat $PRIV(name) $name] 2170 set type slave 2171 } elseif {[interp exists [concat $OPT(exec) $name]]} { 2172 set name [concat $path $name] 2173 set type slave 2174 } elseif {[lsearch -exact [::send::interps] $name] > -1} { 2175 if {[EvalSlave info exists tk_library] 2176 && $name eq [EvalSlave tk appname]} { 2177 set name {} 2178 set app $path 2179 set type slave 2180 } elseif {[set i [lsearch -exact \ 2181 [Main set ::tkcon::PRIV(interps)] $name]] != -1} { 2182 set name [lindex [Main set ::tkcon::PRIV(slaves)] $i] 2183 if {[string match {[Mm]ain} $name]} { set app Main } 2184 set type slave 2185 } else { 2186 set type interp 2187 } 2188 } else { 2189 return -code error "No known interpreter \"$name\"" 2190 } 2191 } else { 2192 set app $path 2193 } 2194 if {![info exists app]} { set app $name } 2195 array set PRIV [list app $app appname $name apptype $type deadapp 0] 2196 2197 ## ::tkcon::EvalAttached - evaluates the args in the attached interp 2198 ## args should be passed to this procedure as if they were being 2199 ## passed to the 'eval' procedure. This procedure is dynamic to 2200 ## ensure evaluation occurs in the right interp. 2201 # ARGS: args - the command and args to evaluate 2202 ## 2203 set PRIV(namesp) :: 2204 set namespOK 0 2205 switch -glob -- $type { 2206 slave { 2207 if {$name eq ""} { 2208 interp alias {} ::tkcon::EvalAttached {} \ 2209 ::tkcon::EvalSlave uplevel \#0 2210 } elseif {$PRIV(app) eq "Main"} { 2211 interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main 2212 } elseif {$PRIV(name) eq $PRIV(app)} { 2213 interp alias {} ::tkcon::EvalAttached {} uplevel \#0 2214 } else { 2215 interp alias {} ::tkcon::EvalAttached {} \ 2216 ::tkcon::Slave $::tkcon::PRIV(app) 2217 } 2218 set namespOK 1 2219 } 2220 sock* { 2221 interp alias {} ::tkcon::EvalAttached {} \ 2222 ::tkcon::EvalSlave uplevel \#0 2223 # The file event will just puts whatever data is found 2224 # into the interpreter 2225 fconfigure $name -buffering line -blocking 0 2226 fileevent $name readable [list ::tkcon::EvalSocketEvent $name] 2227 } 2228 dpy:* - 2229 interp { 2230 if {$OPT(nontcl)} { 2231 interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave 2232 } else { 2233 interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend 2234 set namespOK 1 2235 } 2236 } 2237 default { 2238 return -code error "[lindex [info level 0] 0] did not specify\ 2239 a valid type: must be slave or interp" 2240 } 2241 } 2242 if {$ns ne "" && $namespOK} { 2243 AttachNamespace $ns 2244 } 2245 return [AttachId] 2246} 2247 2248proc ::tkcon::AttachId {} { 2249 # return Attach info in a form that Attach accepts again 2250 variable PRIV 2251 2252 if {$PRIV(appname) eq ""} { 2253 variable OPT 2254 set appname [concat $PRIV(name) $OPT(exec)] 2255 } else { 2256 set appname $PRIV(appname) 2257 } 2258 set id [list $appname $PRIV(apptype)] 2259 # only display ns info if it isn't "::" as that is what is also 2260 # used to indicate no eval in namespace 2261 if {$PRIV(namesp) ne "::"} { lappend id $PRIV(namesp) } 2262 if {[info exists PRIV(console)]} { 2263 variable ATTACH 2264 set ATTACH($PRIV(console)) $id 2265 } 2266 return $id 2267} 2268 2269## ::tkcon::AttachNamespace - called to attach tkcon to a namespace 2270# ARGS: name - namespace name in which tkcon should eval commands 2271# Results: ::tkcon::EvalAttached will be modified 2272## 2273proc ::tkcon::AttachNamespace { name } { 2274 variable PRIV 2275 variable OPT 2276 2277 # We could enable 'socket' bound Tcl interps, but we'd have to create 2278 # a return listening socket 2279 if {($OPT(nontcl) && $PRIV(apptype) eq "interp") 2280 || $PRIV(apptype) eq "socket" 2281 || $PRIV(deadapp)} { 2282 return -code error "can't attach to namespace in attached environment" 2283 } 2284 if {$name eq "Main"} {set name ::} 2285 if {$name ne "" && [lsearch [Namespaces ::] $name] == -1} { 2286 return -code error "No known namespace \"$name\"" 2287 } 2288 if {[regexp {^(|::)$} $name]} { 2289 ## If name=={} || ::, we want the primary namespace 2290 set alias [interp alias {} ::tkcon::EvalAttached] 2291 if {[string match ::tkcon::EvalNamespace* $alias]} { 2292 eval [list interp alias {} ::tkcon::EvalAttached {}] \ 2293 [lindex $alias 1] 2294 } 2295 set name :: 2296 } else { 2297 interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalNamespace \ 2298 [interp alias {} ::tkcon::EvalAttached] [list $name] 2299 } 2300 set PRIV(namesp) $name 2301 return [AttachId] 2302} 2303 2304## ::tkcon::NewSocket - called to create a socket to connect to 2305# ARGS: none 2306# Results: It will create a socket, and attach if requested 2307## 2308proc ::tkcon::NewSocket {} { 2309 variable PRIV 2310 2311 set t $PRIV(base).newsock 2312 if {![winfo exists $t]} { 2313 toplevel $t 2314 wm withdraw $t 2315 catch {wm attributes $t -type dialog} 2316 wm title $t "tkcon Create Socket" 2317 label $t.lhost -text "Host: " 2318 entry $t.host -width 16 -takefocus 1 2319 label $t.lport -text "Port: " 2320 entry $t.port -width 4 -takefocus 1 2321 button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 \ 2322 -takefocus 1 2323 bind $t.host <Return> [list focus $t.port] 2324 bind $t.port <Return> [list focus $t.ok] 2325 bind $t.ok <Return> [list $t.ok invoke] 2326 grid $t.lhost $t.host $t.lport $t.port $t.ok -sticky ew 2327 grid configure $t.ok -padx 4 -pady 2 2328 grid columnconfig $t 1 -weight 1 2329 grid rowconfigure $t 1 -weight 1 2330 wm transient $t $PRIV(root) 2331 wm group $t $PRIV(root) 2332 wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ 2333 reqwidth $t]) / 2}]+[expr {([winfo \ 2334 screenheight $t]-[winfo reqheight $t]) / 2}] 2335 bind $t <Escape> [list destroy $t] 2336 } 2337 #$t.host delete 0 end 2338 #$t.port delete 0 end 2339 wm deiconify $t 2340 raise $t 2341 grab $t 2342 focus $t.host 2343 vwait ::tkcon::PRIV(grab) 2344 grab release $t 2345 wm withdraw $t 2346 set host [$t.host get] 2347 set port [$t.port get] 2348 if {$host == ""} { return } 2349 if {[catch { 2350 set sock [socket $host $port] 2351 } err]} { 2352 tk_messageBox -title "Socket Connection Error" \ 2353 -message "Unable to connect to \"$host:$port\":\n$err" \ 2354 -icon error -type ok 2355 } else { 2356 Attach $sock socket 2357 } 2358} 2359 2360## ::tkcon::Load - sources a file into the console 2361## The file is actually sourced in the currently attached's interp 2362# ARGS: fn - (optional) filename to source in 2363# Returns: selected filename ({} if nothing was selected) 2364## 2365proc ::tkcon::Load { {fn ""} } { 2366 set types { 2367 {{Tcl Files} {.tcl .tk}} 2368 {{Text Files} {.txt}} 2369 {{All Files} *} 2370 } 2371 # Allow for VFS directories, use Tk dialogs automatically when in 2372 # VFS-based areas 2373 set check [expr {$fn == "" ? [pwd] : $fn}] 2374 if {$::tcl_version >= 8.4 && [lindex [file system $check] 0] == "tclvfs"} { 2375 set opencmd [list ::tk::dialog::file:: open] 2376 } else { 2377 set opencmd [list tk_getOpenFile] 2378 } 2379 if {$fn eq "" && 2380 ([catch {tk_getOpenFile -filetypes $types \ 2381 -title "Source File"} fn] || $fn eq "") 2382 } { return } 2383 EvalAttached [list source $fn] 2384} 2385 2386## ::tkcon::Save - saves the console or other widget buffer to a file 2387## This does not eval in a slave because it's not necessary 2388# ARGS: w - console text widget 2389# fn - (optional) filename to save to 2390## 2391proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } { 2392 variable PRIV 2393 2394 if {![regexp -nocase {^(all|history|stdin|stdout|stderr|widget)$} $type]} { 2395 array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel } 2396 ## Allow user to specify what kind of stuff to save 2397 set type [tk_dialog $PRIV(base).savetype "Save Type" \ 2398 "What part of the text do you want to save?" \ 2399 questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)] 2400 if {$type == 5 || $type == -1} return 2401 set type $s($type) 2402 } 2403 # Allow for VFS directories, use Tk dialogs automatically when in 2404 # VFS-based areas 2405 set check [expr {$opt == "" ? [pwd] : $opt}] 2406 if {$::tcl_version >= 8.4 && [lindex [file system $check] 0] == "tclvfs"} { 2407 set savecmd [list ::tk::dialog::file:: save] 2408 } else { 2409 set savecmd [list tk_getSaveFile] 2410 } 2411 if {$fn eq ""} { 2412 set types { 2413 {{Tcl Files} {.tcl .tk}} 2414 {{Text Files} {.txt}} 2415 {{All Files} *} 2416 } 2417 if {[catch {eval $savecmd [list -defaultextension .tcl \ 2418 -filetypes $types \ 2419 -title "Save $type"]} fn] 2420 || $fn eq ""} return 2421 } 2422 set type [string tolower $type] 2423 switch $type { 2424 stdin - stdout - stderr { 2425 set data {} 2426 foreach {first last} [$PRIV(console) tag ranges $type] { 2427 lappend data [$PRIV(console) get $first $last] 2428 } 2429 set data [join $data \n] 2430 } 2431 history { set data [tkcon history] } 2432 all - default { set data [$PRIV(console) get 1.0 end-1c] } 2433 widget { 2434 set data [$opt get 1.0 end-1c] 2435 } 2436 } 2437 if {[catch {open $fn $mode} fid]} { 2438 return -code error "Save Error: Unable to open '$fn' for writing\n$fid" 2439 } 2440 puts -nonewline $fid $data 2441 close $fid 2442} 2443 2444## ::tkcon::MainInit 2445## This is only called for the main interpreter to include certain procs 2446## that we don't want to include (or rather, just alias) in slave interps. 2447## 2448proc ::tkcon::MainInit {} { 2449 variable PRIV 2450 variable OPT 2451 2452 if {![info exists PRIV(slaves)]} { 2453 array set PRIV [list slave 0 slaves Main name {} \ 2454 interps [list [tk appname]]] 2455 } 2456 interp alias {} ::tkcon::Main {} ::tkcon::InterpEval Main 2457 interp alias {} ::tkcon::Slave {} ::tkcon::InterpEval 2458 2459 proc ::tkcon::GetSlave {{slave {}}} { 2460 set i 0 2461 while {[Slave $slave [list interp exists Slave[incr i]]]} { 2462 # oh my god, an empty loop! 2463 } 2464 set interp [Slave $slave [list interp create Slave$i]] 2465 return $interp 2466 } 2467 2468 ## ::tkcon::New - create new console window 2469 ## Creates a slave interpreter and sources in this script. 2470 ## All other interpreters also get a command to eval function in the 2471 ## new interpreter. 2472 ## 2473 proc ::tkcon::New {} { 2474 variable PRIV 2475 global argv0 argc argv 2476 2477 set tmp [GetSlave] 2478 lappend PRIV(slaves) $tmp 2479 load {} Tk $tmp 2480 # If we have tbcload, then that should be autoloaded into slaves. 2481 set idx [lsearch [info loaded] "* Tbcload"] 2482 if {$idx != -1} { catch {load {} Tbcload $tmp} } 2483 lappend PRIV(interps) [$tmp eval [list tk appname \ 2484 "[tk appname] $tmp"]] 2485 if {[info exists argv0]} {$tmp eval [list set argv0 $argv0]} 2486 if {[info exists argc]} {$tmp eval [list set argc $argc]} 2487 if {[info exists argv]} {$tmp eval [list set argv $argv]} 2488 $tmp eval [list namespace eval ::tkcon {}] 2489 $tmp eval [list set ::tkcon::PRIV(name) $tmp] 2490 $tmp eval [list set ::tkcon::PRIV(SCRIPT) $::tkcon::PRIV(SCRIPT)] 2491 $tmp alias exit ::tkcon::Exit $tmp 2492 $tmp alias ::tkcon::Destroy ::tkcon::Destroy $tmp 2493 $tmp alias ::tkcon::New ::tkcon::New 2494 $tmp alias ::tkcon::GetSlave ::tkcon::GetSlave $tmp 2495 $tmp alias ::tkcon::Main ::tkcon::InterpEval Main 2496 $tmp alias ::tkcon::Slave ::tkcon::InterpEval 2497 $tmp alias ::tkcon::Interps ::tkcon::Interps 2498 $tmp alias ::tkcon::NewDisplay ::tkcon::NewDisplay 2499 $tmp alias ::tkcon::Display ::tkcon::Display 2500 $tmp alias ::tkcon::StateCheckpoint ::tkcon::StateCheckpoint 2501 $tmp alias ::tkcon::StateCleanup ::tkcon::StateCleanup 2502 $tmp alias ::tkcon::StateCompare ::tkcon::StateCompare 2503 $tmp alias ::tkcon::StateRevert ::tkcon::StateRevert 2504 $tmp eval { 2505 if [catch {source -rsrc tkcon}] { source $::tkcon::PRIV(SCRIPT) } 2506 } 2507 return $tmp 2508 } 2509 2510 ## ::tkcon::Exit - full exit OR destroy slave console 2511 ## This proc should only be called in the main interpreter from a slave. 2512 ## The master determines whether we do a full exit or just kill the slave. 2513 ## 2514 proc ::tkcon::Exit {slave args} { 2515 variable PRIV 2516 variable OPT 2517 2518 ## Slave interpreter exit request 2519 if {$OPT(slaveexit) eq "exit" || [llength $PRIV(interps)] == 1} { 2520 ## Only exit if it specifically is stated to do so, or this 2521 ## is the last interp 2522 uplevel 1 exit $args 2523 } else { 2524 ## Otherwise we will delete the slave interp and associated data 2525 Destroy $slave 2526 } 2527 } 2528 2529 ## ::tkcon::Destroy - destroy console window 2530 ## This proc should only be called by the main interpreter. If it is 2531 ## called from there, it will ask before exiting tkcon. All others 2532 ## (slaves) will just have their slave interpreter deleted, closing them. 2533 ## 2534 proc ::tkcon::Destroy {{slave {}}} { 2535 variable PRIV 2536 2537 # Just close on the last one 2538 if {[llength $PRIV(interps)] == 1} { exit } 2539 if {"" == $slave} { 2540 ## Main interpreter close request 2541 if {[tk_messageBox -parent $PRIV(root) -title "Quit tkcon?" \ 2542 -message "Close all windows and exit tkcon?" \ 2543 -icon question -type yesno] == "yes"} { exit } 2544 return 2545 } elseif {$slave == $::tkcon::OPT(exec)} { 2546 set name [tk appname] 2547 set slave "Main" 2548 } else { 2549 ## Slave interpreter close request 2550 set name [InterpEval $slave] 2551 interp delete $slave 2552 } 2553 set PRIV(interps) [lremove $PRIV(interps) [list $name]] 2554 set PRIV(slaves) [lremove $PRIV(slaves) [list $slave]] 2555 StateCleanup $slave 2556 } 2557 2558 if {$OPT(overrideexit)} { 2559 ## We want to do a couple things before exiting... 2560 if {[catch {rename ::exit ::tkcon::FinalExit} err]} { 2561 puts stderr "tkcon might panic:\n$err" 2562 } 2563 proc ::exit args { 2564 if {$::tkcon::OPT(usehistory)} { 2565 if {[catch {open $::tkcon::PRIV(histfile) w} fid]} { 2566 puts stderr "unable to save history file:\n$fid" 2567 # pause a moment, because we are about to die finally... 2568 after 1000 2569 } else { 2570 set max [::tkcon::EvalSlave history nextid] 2571 set id [expr {$max - $::tkcon::OPT(history)}] 2572 if {$id < 1} { set id 1 } 2573 ## FIX: This puts history in backwards!! 2574 while {($id < $max) && ![catch \ 2575 {::tkcon::EvalSlave history event $id} cmd]} { 2576 if {$cmd ne ""} { 2577 puts $fid "::tkcon::EvalSlave\ 2578 history add [list $cmd]" 2579 } 2580 incr id 2581 } 2582 close $fid 2583 } 2584 } 2585 uplevel 1 ::tkcon::FinalExit $args 2586 } 2587 } 2588 2589 ## ::tkcon::InterpEval - passes evaluation to another named interpreter 2590 ## If the interpreter is named, but no args are given, it returns the 2591 ## [tk appname] of that interps master (not the associated eval slave). 2592 ## 2593 proc ::tkcon::InterpEval {{slave {}} args} { 2594 variable PRIV 2595 2596 if {[llength [info level 0]] == 1} { 2597 # no args given 2598 return $PRIV(slaves) 2599 } elseif {[string match {[Mm]ain} $slave]} { 2600 set slave {} 2601 } 2602 if {[llength $args]} { 2603 return [interp eval $slave uplevel \#0 $args] 2604 } else { 2605 # beware safe interps with Tk 2606 if {[interp eval $slave {llength [info commands tk]}]} { 2607 if {[catch {interp eval $slave tk appname} name]} { 2608 return "safetk" 2609 } 2610 return $name 2611 } 2612 } 2613 } 2614 2615 proc ::tkcon::Interps {{ls {}} {interp {}}} { 2616 if {$interp eq ""} { 2617 lappend ls {} [tk appname] 2618 } 2619 foreach i [interp slaves $interp] { 2620 if {$interp ne ""} { set i "$interp $i" } 2621 if {[interp eval $i package provide Tk] ne ""} { 2622 # beware safe interps with Tk 2623 if {[catch {interp eval $i tk appname} name]} { 2624 set name {} 2625 } 2626 lappend ls $i $name 2627 } else { 2628 lappend ls $i {} 2629 } 2630 set ls [Interps $ls $i] 2631 } 2632 return $ls 2633 } 2634 2635 proc ::tkcon::Display {{disp {}}} { 2636 variable DISP 2637 2638 set res {} 2639 if {$disp != ""} { 2640 if {![info exists DISP($disp)]} { return } 2641 return [list $DISP($disp) [winfo interps -displayof $DISP($disp)]] 2642 } 2643 return [lsort -dictionary [array names DISP]] 2644 } 2645 2646 proc ::tkcon::NewDisplay {} { 2647 variable PRIV 2648 variable DISP 2649 2650 set t $PRIV(base).newdisp 2651 if {![winfo exists $t]} { 2652 toplevel $t 2653 wm withdraw $t 2654 catch {wm attributes $t -type dialog} 2655 wm title $t "tkcon Attach to Display" 2656 label $t.gets -text "New Display: " 2657 entry $t.data -width 32 2658 button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} 2659 bind $t.data <Return> [list $t.ok invoke] 2660 bind $t.ok <Return> [list $t.ok invoke] 2661 grid $t.gets $t.data -sticky ew 2662 grid $t.ok - -sticky ew 2663 grid columnconfig $t 1 -weight 1 2664 grid rowconfigure $t 1 -weight 1 2665 wm transient $t $PRIV(root) 2666 wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ 2667 reqwidth $t]) / 2}]+[expr {([winfo \ 2668 screenheight $t]-[winfo reqheight $t]) / 2}] 2669 } 2670 $t.data delete 0 end 2671 wm deiconify $t 2672 raise $t 2673 grab $t 2674 focus $t.data 2675 vwait ::tkcon::PRIV(grab) 2676 grab release $t 2677 wm withdraw $t 2678 set disp [$t.data get] 2679 if {$disp == ""} { return } 2680 regsub -all {\.} [string tolower $disp] ! dt 2681 set dt $PRIV(base).$dt 2682 destroy $dt 2683 if {[catch { 2684 toplevel $dt -screen $disp 2685 set interps [winfo interps -displayof $dt] 2686 if {![llength $interps]} { 2687 error "No other Tk interpreters on $disp" 2688 } 2689 ::send::send -displayof $dt [lindex $interps 0] [list info tclversion] 2690 } err]} { 2691 global env 2692 if {[info exists env(DISPLAY)]} { 2693 set myd $env(DISPLAY) 2694 } else { 2695 set myd "myDisplay:0" 2696 } 2697 tk_messageBox -title "Display Connection Error" \ 2698 -message "Unable to connect to \"$disp\":\n$err\ 2699 \nMake sure you have xauth-based permissions\ 2700 (xauth add $myd . `mcookie`), and xhost is disabled\ 2701 (xhost -) on \"$disp\"" \ 2702 -icon error -type ok 2703 destroy $dt 2704 return 2705 } 2706 set DISP($disp) $dt 2707 wm withdraw $dt 2708 bind $dt <Destroy> [subst {catch {unset ::tkcon::DISP($disp)}}] 2709 tk_messageBox -title "$disp Connection" \ 2710 -message "Connected to \"$disp\", found:\n[join $interps \n]" \ 2711 -type ok 2712 } 2713 2714 ## 2715 ## The following state checkpoint/revert procedures are very sketchy 2716 ## and prone to problems. They do not track modifications to currently 2717 ## existing procedures/variables, and they can really screw things up 2718 ## if you load in libraries (especially Tk) between checkpoint and 2719 ## revert. Only with this knowledge in mind should you use these. 2720 ## 2721 2722 ## ::tkcon::StateCheckpoint - checkpoints the current state of the system 2723 ## This allows you to return to this state with ::tkcon::StateRevert 2724 # ARGS: 2725 ## 2726 proc ::tkcon::StateCheckpoint {app type} { 2727 variable CPS 2728 variable PRIV 2729 2730 if {[info exists CPS($type,$app,cmd)] && \ 2731 [tk_dialog $PRIV(base).warning "Overwrite Previous State?" \ 2732 "Are you sure you want to lose previously checkpointed\ 2733 state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return 2734 set CPS($type,$app,cmd) [EvalOther $app $type info commands *] 2735 set CPS($type,$app,var) [EvalOther $app $type info vars *] 2736 return 2737 } 2738 2739 ## ::tkcon::StateCompare - compare two states and output difference 2740 # ARGS: 2741 ## 2742 proc ::tkcon::StateCompare {app type {verbose 0}} { 2743 variable CPS 2744 variable PRIV 2745 variable OPT 2746 variable COLOR 2747 2748 if {![info exists CPS($type,$app,cmd)]} { 2749 return -code error \ 2750 "No previously checkpointed state for $type \"$app\"" 2751 } 2752 set w $PRIV(base).compare 2753 if {[winfo exists $w]} { 2754 $w.text config -state normal 2755 $w.text delete 1.0 end 2756 } else { 2757 toplevel $w 2758 catch {wm attributes $w -type dialog} 2759 frame $w.btn 2760 scrollbar $w.sy -command [list $w.text yview] 2761 text $w.text -yscrollcommand [list $w.sy set] -height 12 \ 2762 -foreground $COLOR(stdin) \ 2763 -background $COLOR(bg) \ 2764 -insertbackground $COLOR(cursor) \ 2765 -font $OPT(font) -borderwidth 1 -highlightthickness 0 2766 pack $w.btn -side bottom -fill x 2767 pack $w.sy -side right -fill y 2768 pack $w.text -fill both -expand 1 2769 button $w.btn.close -text "Dismiss" -width 11 \ 2770 -command [list destroy $w] 2771 button $w.btn.check -text "Recheckpoint" -width 11 2772 button $w.btn.revert -text "Revert" -width 11 2773 button $w.btn.expand -text "Verbose" -width 11 2774 button $w.btn.update -text "Update" -width 11 2775 pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \ 2776 $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1 2777 $w.text tag config red -foreground red 2778 } 2779 wm title $w "Compare State: $type [list $app]" 2780 2781 $w.btn.check config \ 2782 -command "::tkcon::StateCheckpoint [list $app] $type; \ 2783 ::tkcon::StateCompare [list $app] $type $verbose" 2784 $w.btn.revert config \ 2785 -command "::tkcon::StateRevert [list $app] $type; \ 2786 ::tkcon::StateCompare [list $app] $type $verbose" 2787 $w.btn.update config -command [info level 0] 2788 if {$verbose} { 2789 $w.btn.expand config -text Brief \ 2790 -command [list ::tkcon::StateCompare $app $type 0] 2791 } else { 2792 $w.btn.expand config -text Verbose \ 2793 -command [list ::tkcon::StateCompare $app $type 1] 2794 } 2795 ## Don't allow verbose mode unless 'dump' exists in $app 2796 ## We're assuming this is tkcon's dump command 2797 set hasdump [llength [EvalOther $app $type info commands dump]] 2798 if {$hasdump} { 2799 $w.btn.expand config -state normal 2800 } else { 2801 $w.btn.expand config -state disabled 2802 } 2803 2804 set cmds [lremove [EvalOther $app $type info commands *] \ 2805 $CPS($type,$app,cmd)] 2806 set vars [lremove [EvalOther $app $type info vars *] \ 2807 $CPS($type,$app,var)] 2808 2809 if {$hasdump && $verbose} { 2810 set cmds [EvalOther $app $type eval dump c -nocomplain $cmds] 2811 set vars [EvalOther $app $type eval dump v -nocomplain $vars] 2812 } 2813 $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \ 2814 $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {} 2815 2816 raise $w 2817 $w.text config -state disabled 2818 } 2819 2820 ## ::tkcon::StateRevert - reverts interpreter to previous state 2821 # ARGS: 2822 ## 2823 proc ::tkcon::StateRevert {app type} { 2824 variable CPS 2825 variable PRIV 2826 2827 if {![info exists CPS($type,$app,cmd)]} { 2828 return -code error \ 2829 "No previously checkpointed state for $type \"$app\"" 2830 } 2831 if {![tk_dialog $PRIV(base).warning "Revert State?" \ 2832 "Are you sure you want to revert the state in $type \"$app\"?"\ 2833 questhead 1 "Do It" "Cancel"]} { 2834 foreach i [lremove [EvalOther $app $type info commands *] \ 2835 $CPS($type,$app,cmd)] { 2836 catch {EvalOther $app $type rename $i {}} 2837 } 2838 foreach i [lremove [EvalOther $app $type info vars *] \ 2839 $CPS($type,$app,var)] { 2840 catch {EvalOther $app $type unset $i} 2841 } 2842 } 2843 } 2844 2845 ## ::tkcon::StateCleanup - cleans up state information in master array 2846 # 2847 ## 2848 proc ::tkcon::StateCleanup {args} { 2849 variable CPS 2850 2851 if {![llength $args]} { 2852 foreach state [array names CPS slave,*] { 2853 if {![interp exists [string range $state 6 end]]} { 2854 unset CPS($state) 2855 } 2856 } 2857 } else { 2858 set app [lindex $args 0] 2859 set type [lindex $args 1] 2860 if {[regexp {^(|slave)$} $type]} { 2861 foreach state [array names CPS "slave,$app\[, \]*"] { 2862 if {![interp exists [string range $state 6 end]]} { 2863 unset CPS($state) 2864 } 2865 } 2866 } else { 2867 catch {unset CPS($type,$app)} 2868 } 2869 } 2870 } 2871} 2872 2873## ::tkcon::Event - get history event, search if string != {} 2874## look forward (next) if $int>0, otherwise look back (prev) 2875# ARGS: W - console widget 2876## 2877proc ::tkcon::Event {int {str {}}} { 2878 if {!$int} return 2879 2880 variable PRIV 2881 set w $PRIV(console) 2882 2883 set nextid [EvalSlave history nextid] 2884 if {$str ne ""} { 2885 ## String is not empty, do an event search 2886 set event $PRIV(event) 2887 if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str } 2888 set len [string len $PRIV(cmdbuf)] 2889 incr len -1 2890 if {$int > 0} { 2891 ## Search history forward 2892 while {$event < $nextid} { 2893 if {[incr event] == $nextid} { 2894 $w delete limit end 2895 $w insert limit $PRIV(cmdbuf) 2896 break 2897 } elseif { 2898 ![catch {EvalSlave history event $event} res] && 2899 [set p [string first $PRIV(cmdbuf) $res]] > -1 2900 } { 2901 set p2 [expr {$p + [string length $PRIV(cmdbuf)]}] 2902 $w delete limit end 2903 $w insert limit $res 2904 Blink $w "limit + $p c" "limit + $p2 c" 2905 break 2906 } 2907 } 2908 set PRIV(event) $event 2909 } else { 2910 ## Search history reverse 2911 while {![catch {EvalSlave history event [incr event -1]} res]} { 2912 if {[set p [string first $PRIV(cmdbuf) $res]] > -1} { 2913 set p2 [expr {$p + [string length $PRIV(cmdbuf)]}] 2914 $w delete limit end 2915 $w insert limit $res 2916 set PRIV(event) $event 2917 Blink $w "limit + $p c" "limit + $p2 c" 2918 break 2919 } 2920 } 2921 } 2922 } else { 2923 ## String is empty, just get next/prev event 2924 if {$int > 0} { 2925 ## Goto next command in history 2926 if {$PRIV(event) < $nextid} { 2927 $w delete limit end 2928 if {[incr PRIV(event)] == $nextid} { 2929 $w insert limit $PRIV(cmdbuf) 2930 } else { 2931 $w insert limit [EvalSlave history event $PRIV(event)] 2932 } 2933 } 2934 } else { 2935 ## Goto previous command in history 2936 if {$PRIV(event) == $nextid} { 2937 set PRIV(cmdbuf) [CmdGet $w] 2938 } 2939 if {[catch {EvalSlave history event [incr PRIV(event) -1]} res]} { 2940 incr PRIV(event) 2941 } else { 2942 $w delete limit end 2943 $w insert limit $res 2944 } 2945 } 2946 } 2947 $w mark set insert end 2948 $w see end 2949} 2950 2951## ::tkcon::Highlight - magic highlighting 2952## beware: voodoo included 2953# ARGS: 2954## 2955proc ::tkcon::Highlight {w type} { 2956 variable COLOR 2957 variable OPT 2958 2959 switch -exact $type { 2960 "error" { HighlightError $w } 2961 "tcl" - "test" { 2962 if {[winfo class $w] != "Ctext"} { return } 2963 2964 foreach {app type} [tkcon attach] {break} 2965 set cmds [::tkcon::EvalOther $app $type info commands] 2966 2967 set classes [list \ 2968 [list comment ClassForRegexp "^\\s*#\[^\n\]*" $COLOR(stderr)] \ 2969 [list var ClassWithOnlyCharStart "\$" $COLOR(stdout)] \ 2970 [list syntax ClassForSpecialChars "\[\]{}\"" $COLOR(prompt)] \ 2971 [list command Class $cmds $COLOR(proc)] \ 2972 ] 2973 2974 # Remove all highlight classes from a widget 2975 ctext::clearHighlightClasses $w 2976 foreach class $classes { 2977 foreach {cname ctype cptn ccol} $class break 2978 ctext::addHighlight$ctype $w $cname $ccol $cptn 2979 } 2980 $w highlight 1.0 end 2981 } 2982 } 2983} 2984 2985## ::tkcon::HighlightError - magic error highlighting 2986## beware: voodoo included 2987# ARGS: 2988## 2989proc ::tkcon::HighlightError w { 2990 variable COLOR 2991 variable OPT 2992 2993 ## do voodoo here 2994 set app [Attach] 2995 # we have to pull the text out, because text regexps are screwed on \n's. 2996 set info [$w get 1.0 end-1c] 2997 # Check for specific line error in a proc 2998 set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\"" 2999 # Check for too few args to a proc 3000 set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\"" 3001 set start 1.0 3002 while { 3003 [regexp -indices -- $exp(proc) $info junk what cmd] || 3004 [regexp -indices -- $exp(param) $info junk what cmd] 3005 } { 3006 foreach {w0 w1} $what {c0 c1} $cmd {break} 3007 set what [string range $info $w0 $w1] 3008 set cmd [string range $info $c0 $c1] 3009 if {[string match *::* $cmd]} { 3010 set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \ 3011 [list [namespace qualifiers $cmd] \ 3012 [list info procs [namespace tail $cmd]]]] 3013 } else { 3014 set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]] 3015 } 3016 if {[llength $res]==1} { 3017 set tag [UniqueTag $w] 3018 $w tag add $tag $start+${c0}c $start+1c+${c1}c 3019 $w tag configure $tag -foreground $COLOR(stdout) 3020 $w tag bind $tag <Enter> [list $w tag configure $tag -under 1] 3021 $w tag bind $tag <Leave> [list $w tag configure $tag -under 0] 3022 $w tag bind $tag <ButtonRelease-1> "if {!\$tk::Priv(mouseMoved)} \ 3023 {[list $OPT(edit) -attach $app -type proc -find $what -- $cmd]}" 3024 } 3025 set info [string range $info $c1 end] 3026 set start [$w index $start+${c1}c] 3027 } 3028 ## Next stage, check for procs that start a line 3029 set start 1.0 3030 set exp(cmd) "^\"\[^\" \t\n\]+" 3031 while { 3032 [string compare {} [set ix \ 3033 [$w search -regexp -count numc -- $exp(cmd) $start end]]] 3034 } { 3035 set start [$w index $ix+${numc}c] 3036 # +1c to avoid the first quote 3037 set cmd [$w get $ix+1c $start] 3038 if {[string match *::* $cmd]} { 3039 set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \ 3040 [list [namespace qualifiers $cmd] \ 3041 [list info procs [namespace tail $cmd]]]] 3042 } else { 3043 set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]] 3044 } 3045 if {[llength $res]==1} { 3046 set tag [UniqueTag $w] 3047 $w tag add $tag $ix+1c $start 3048 $w tag configure $tag -foreground $COLOR(proc) 3049 $w tag bind $tag <Enter> [list $w tag configure $tag -under 1] 3050 $w tag bind $tag <Leave> [list $w tag configure $tag -under 0] 3051 $w tag bind $tag <ButtonRelease-1> "if {!\$tk::Priv(mouseMoved)} \ 3052 {[list $OPT(edit) -attach $app -type proc -- $cmd]}" 3053 } 3054 } 3055} 3056 3057proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} { 3058 global env 3059 3060 if {$termcap} { 3061 set env(TERM) "tt" 3062 set env(TERMCAP) {tt: 3063 :ks=\E[KS: 3064 :ke=\E[KE: 3065 :cm=\E[%d;%dH: 3066 :up=\E[A: 3067 :nd=\E[C: 3068 :cl=\E[H\E[J: 3069 :do=^J: 3070 :so=\E[7m: 3071 :se=\E[m: 3072 :k1=\EOP: 3073 :k2=\EOQ: 3074 :k3=\EOR: 3075 :k4=\EOS: 3076 :k5=\EOT: 3077 :k6=\EOU: 3078 :k7=\EOV: 3079 :k8=\EOW: 3080 :k9=\EOX: 3081 } 3082 } 3083 3084 if {$terminfo} { 3085 set env(TERM) "tkterm" 3086 if {![info exists env(TEMP)]} { set env(TEMP) /tmp } 3087 set env(TERMINFO) $env(TEMP) 3088 3089 set ttsrc [file join $env(TEMP) tt.src] 3090 set file [open $ttsrc w] 3091 puts $file {tkterm|Don Libes' tk text widget terminal emulator, 3092 smkx=\E[KS, 3093 rmkx=\E[KE, 3094 cup=\E[%p1%d;%p2%dH, 3095 cuu1=\E[A, 3096 cuf1=\E[C, 3097 clear=\E[H\E[J, 3098 ind=\n, 3099 cr=\r, 3100 smso=\E[7m, 3101 rmso=\E[m, 3102 kf1=\EOP, 3103 kf2=\EOQ, 3104 kf3=\EOR, 3105 kf4=\EOS, 3106 kf5=\EOT, 3107 kf6=\EOU, 3108 kf7=\EOV, 3109 kf8=\EOW, 3110 kf9=\EOX, 3111 } 3112 close $file 3113 3114 if {[catch {exec tic $ttsrc} msg]} { 3115 return -code error \ 3116 "tic failed, you may not have terminfo support:\n$msg" 3117 } 3118 3119 file delete $ttsrc 3120 } 3121} 3122 3123# term_exit is called if the spawned process exits 3124proc ::tkcon::term_exit {w} { 3125 variable EXP 3126 catch {exp_close -i $EXP(spawn_id)} 3127 set EXP(forever) 1 3128 unset EXP 3129} 3130 3131# term_chars_changed is called after every change to the displayed chars 3132# You can use if you want matches to occur in the background (a la bind) 3133# If you want to test synchronously, then just do so - you don't need to 3134# redefine this procedure. 3135proc ::tkcon::term_chars_changed {w args} { 3136} 3137 3138# term_cursor_changed is called after the cursor is moved 3139proc ::tkcon::term_cursor_changed {w args} { 3140} 3141 3142proc ::tkcon::term_update_cursor {w args} { 3143 variable OPT 3144 variable EXP 3145 3146 $w mark set insert $EXP(row).$EXP(col) 3147 $w see insert 3148 term_cursor_changed $w 3149} 3150 3151proc ::tkcon::term_clear {w args} { 3152 $w delete 1.0 end 3153 term_init $w 3154} 3155 3156proc ::tkcon::term_init {w args} { 3157 variable OPT 3158 variable EXP 3159 3160 # initialize it with blanks to make insertions later more easily 3161 set blankline [string repeat " " $OPT(cols)]\n 3162 for {set i 1} {$i <= $OPT(rows)} {incr i} { 3163 $w insert $i.0 $blankline 3164 } 3165 3166 set EXP(row) 1 3167 set EXP(col) 0 3168 3169 $w mark set insert $EXP(row).$EXP(col) 3170} 3171 3172proc ::tkcon::term_down {w args} { 3173 variable OPT 3174 variable EXP 3175 3176 if {$EXP(row) < $OPT(rows)} { 3177 incr EXP(row) 3178 } else { 3179 # already at last line of term, so scroll screen up 3180 $w delete 1.0 2.0 3181 3182 # recreate line at end 3183 $w insert end [string repeat " " $OPT(cols)]\n 3184 } 3185} 3186 3187proc ::tkcon::term_insert {w s} { 3188 variable OPT 3189 variable EXP 3190 3191 set chars_rem_to_write [string length $s] 3192 set space_rem_on_line [expr {$OPT(cols) - $EXP(col)}] 3193 3194 set tag_action [expr {$EXP(standout) ? "add" : "remove"}] 3195 3196 ################## 3197 # write first line 3198 ################## 3199 3200 if {$chars_rem_to_write > $space_rem_on_line} { 3201 set chars_to_write $space_rem_on_line 3202 set newline 1 3203 } else { 3204 set chars_to_write $chars_rem_to_write 3205 set newline 0 3206 } 3207 3208 $w delete $EXP(row).$EXP(col) \ 3209 $EXP(row).[expr {$EXP(col) + $chars_to_write}] 3210 $w insert $EXP(row).$EXP(col) \ 3211 [string range $s 0 [expr {$space_rem_on_line-1}]] 3212 3213 $w tag $tag_action standout $EXP(row).$EXP(col) \ 3214 $EXP(row).[expr {$EXP(col) + $chars_to_write}] 3215 3216 # discard first line already written 3217 incr chars_rem_to_write -$chars_to_write 3218 set s [string range $s $chars_to_write end] 3219 3220 # update EXP(col) 3221 incr EXP(col) $chars_to_write 3222 # update EXP(row) 3223 if {$newline} { term_down $w } 3224 3225 ################## 3226 # write full lines 3227 ################## 3228 while {$chars_rem_to_write >= $OPT(cols)} { 3229 $w delete $EXP(row).0 $EXP(row).end 3230 $w insert $EXP(row).0 [string range $s 0 [expr {$OPT(cols)-1}]] 3231 $w tag $tag_action standout $EXP(row).0 $EXP(row).end 3232 3233 # discard line from buffer 3234 set s [string range $s $OPT(cols) end] 3235 incr chars_rem_to_write -$OPT(cols) 3236 3237 set EXP(col) 0 3238 term_down $w 3239 } 3240 3241 ################# 3242 # write last line 3243 ################# 3244 3245 if {$chars_rem_to_write} { 3246 $w delete $EXP(row).0 $EXP(row).$chars_rem_to_write 3247 $w insert $EXP(row).0 $s 3248 $w tag $tag_action standout $EXP(row).0 $EXP(row).$chars_rem_to_write 3249 set EXP(col) $chars_rem_to_write 3250 } 3251 3252 term_chars_changed $w 3253} 3254 3255proc ::tkcon::Expect {cmd} { 3256 variable OPT 3257 variable PRIV 3258 variable EXP 3259 3260 set EXP(standout) 0 3261 set EXP(row) 0 3262 set EXP(col) 0 3263 3264 set env(LINES) $OPT(rows) 3265 set env(COLUMNS) $OPT(cols) 3266 3267 ExpectInit 3268 log_user 0 3269 set ::stty_init "-tabs" 3270 uplevel \#0 [linsert $cmd 0 spawn] 3271 set EXP(spawn_id) $::spawn_id 3272 if {[info exists ::spawn_out(slave,name)]} { 3273 set EXP(slave,name) $::spawn_out(slave,name) 3274 catch {stty rows $OPT(rows) columns $OPT(cols) < $::spawn_out(slave,name)} 3275 } 3276 if {[string index $cmd end] == "&"} { 3277 set cmd expect_background 3278 } else { 3279 set cmd expect 3280 } 3281 bind $PRIV(console) <Meta-KeyPress> { 3282 if {"%A" != ""} { 3283 exp_send -i $::tkcon::EXP(spawn_id) "\033%A" 3284 break 3285 } 3286 } 3287 bind $PRIV(console) <KeyPress> { 3288 exp_send -i $::tkcon::EXP(spawn_id) -- %A 3289 break 3290 } 3291 bind $PRIV(console) <Control-space> {exp_send -null} 3292 set code [catch { 3293 term_init $PRIV(console) 3294 while {[info exists EXP(spawn_id)]} { 3295 $cmd { 3296 -i $::tkcon::EXP(spawn_id) 3297 -re "^\[^\x01-\x1f\]+" { 3298 # Text 3299 ::tkcon::term_insert $::tkcon::PRIV(console) \ 3300 $expect_out(0,string) 3301 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3302 } "^\r" { 3303 # (cr,) Go to beginning of line 3304 update idle 3305 set ::tkcon::EXP(col) 0 3306 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3307 } "^\n" { 3308 # (ind,do) Move cursor down one line 3309 if {$::tcl_platform(platform) eq "windows"} { 3310 # Windows seems to get the LF without the CR 3311 update idle 3312 set ::tkcon::EXP(col) 0 3313 } 3314 ::tkcon::term_down $::tkcon::PRIV(console) 3315 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3316 } "^\b" { 3317 # Backspace nondestructively 3318 incr ::tkcon::EXP(col) -1 3319 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3320 } "^\a" { 3321 bell 3322 } "^\t" { 3323 # Tab, shouldn't happen 3324 send_error "got a tab!?" 3325 } eof { 3326 ::tkcon::term_exit $::tkcon::PRIV(console) 3327 } "^\x1b\\\[A" { 3328 # Cursor Up (cuu1,up) 3329 incr ::tkcon::EXP(row) -1 3330 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3331 } "^\x1b\\\[B" { 3332 # Cursor Down 3333 incr ::tkcon::EXP(row) 3334 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3335 } "^\x1b\\\[C" { 3336 # Cursor Right (cuf1,nd) 3337 incr ::tkcon::EXP(col) 3338 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3339 } "^\x1b\\\[D" { 3340 # Cursor Left 3341 incr ::tkcon::EXP(col) 3342 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3343 } "^\x1b\\\[H" { 3344 # Cursor Home 3345 } -re "^\x1b\\\[(\[0-9\]*);(\[0-9\]*)H" { 3346 # (cup,cm) Move to row y col x 3347 set ::tkcon::EXP(row) [expr {$expect_out(1,string)+1}] 3348 set ::tkcon::EXP(col) $expect_out(2,string) 3349 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3350 } "^\x1b\\\[H\x1b\\\[J" { 3351 # (clear,cl) Clear screen 3352 ::tkcon::term_clear $::tkcon::PRIV(console) 3353 ::tkcon::term_update_cursor $::tkcon::PRIV(console) 3354 } "^\x1b\\\[7m" { 3355 # (smso,so) Begin standout mode 3356 set ::tkcon::EXP(standout) 1 3357 } "^\x1b\\\[m" { 3358 # (rmso,se) End standout mode 3359 set ::tkcon::EXP(standout) 0 3360 } "^\x1b\\\[KS" { 3361 # (smkx,ks) start keyboard-transmit mode 3362 # terminfo invokes these when going in/out of graphics mode 3363 # In graphics mode, we should have no scrollbars 3364 #graphicsSet 1 3365 } "^\x1b\\\[KE" { 3366 # (rmkx,ke) end keyboard-transmit mode 3367 # Out of graphics mode, we should have scrollbars 3368 #graphicsSet 0 3369 } 3370 } 3371 } 3372 #vwait ::tkcon::EXP(forever) 3373 } err] 3374 bind $PRIV(console) <Meta-KeyPress> {} 3375 bind $PRIV(console) <KeyPress> {} 3376 bind $PRIV(console) <Control-space> {} 3377 catch {unset EXP} 3378 if {$code} { 3379 return -code $code -errorinfo $::errorInfo $err 3380 } 3381} 3382 3383## tkcon - command that allows control over the console 3384## This always exists in the main interpreter, and is aliased into 3385## other connected interpreters 3386# ARGS: totally variable, see internal comments 3387## 3388proc tkcon {cmd args} { 3389 variable ::tkcon::PRIV 3390 variable ::tkcon::OPT 3391 global errorInfo 3392 3393 switch -glob -- $cmd { 3394 buf* { 3395 ## 'buffer' Sets/Query the buffer size 3396 if {[llength $args]} { 3397 if {[regexp {^[1-9][0-9]*$} $args]} { 3398 set OPT(buffer) $args 3399 # catch in case the console doesn't exist yet 3400 catch {::tkcon::ConstrainBuffer $PRIV(console) \ 3401 $OPT(buffer)} 3402 } else { 3403 return -code error "buffer must be a valid integer" 3404 } 3405 } 3406 return $OPT(buffer) 3407 } 3408 linelen* { 3409 ## 'linelength' Sets/Query the maximum line length 3410 if {[llength $args]} { 3411 if {[regexp {^-?[0-9]+$} $args]} { 3412 set OPT(maxlinelen) $args 3413 } else { 3414 return -code error "buffer must be a valid integer" 3415 } 3416 } 3417 return $OPT(maxlinelen) 3418 } 3419 bg* { 3420 ## 'bgerror' Brings up an error dialog 3421 set errorInfo [lindex $args 1] 3422 bgerror [lindex $args 0] 3423 } 3424 cl* { 3425 ## 'close' Closes the console 3426 ::tkcon::Destroy 3427 } 3428 cons* { 3429 ## 'console' - passes the args to the text widget of the console. 3430 set result [uplevel 1 $PRIV(console) $args] 3431 ::tkcon::ConstrainBuffer $PRIV(console) $OPT(buffer) 3432 return $result 3433 } 3434 congets { 3435 ## 'congets' a replacement for [gets stdin] 3436 # Use the 'gets' alias of 'tkcon_gets' command instead of 3437 # calling the *get* methods directly for best compatability 3438 if {[llength $args]} { 3439 return -code error "wrong # args: must be \"tkcon congets\"" 3440 } 3441 tkcon show 3442 set old [bind TkConsole <<TkCon_Eval>>] 3443 bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 } 3444 set w $PRIV(console) 3445 # Make sure to move the limit to get the right data 3446 $w mark set limit end-1c 3447 $w mark gravity limit left 3448 $w mark set insert end 3449 $w see end 3450 vwait ::tkcon::PRIV(wait) 3451 set line [::tkcon::CmdGet $w] 3452 $w insert end \n 3453 bind TkConsole <<TkCon_Eval>> $old 3454 return $line 3455 } 3456 exp* { 3457 ::tkcon::Expect [lindex $args 0] 3458 } 3459 getc* { 3460 ## 'getcommand' a replacement for [gets stdin] 3461 ## This forces a complete command to be input though 3462 if {[llength $args]} { 3463 return -code error "wrong # args: must be \"tkcon getcommand\"" 3464 } 3465 tkcon show 3466 set old [bind TkConsole <<TkCon_Eval>>] 3467 bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 } 3468 set w $PRIV(console) 3469 # Make sure to move the limit to get the right data 3470 $w mark set insert end 3471 $w mark set limit insert 3472 $w see end 3473 vwait ::tkcon::PRIV(wait) 3474 set line [::tkcon::CmdGet $w] 3475 $w insert end \n 3476 while {![info complete $line] || [regexp {[^\\]\\$} $line]} { 3477 vwait ::tkcon::PRIV(wait) 3478 set line [::tkcon::CmdGet $w] 3479 $w insert end \n 3480 $w see end 3481 } 3482 bind TkConsole <<TkCon_Eval>> $old 3483 return $line 3484 } 3485 get - gets { 3486 ## 'gets' - a replacement for [gets stdin] 3487 ## This pops up a text widget to be used for stdin (local grabbed) 3488 if {[llength $args]} { 3489 return -code error "wrong # args: should be \"tkcon gets\"" 3490 } 3491 set t $PRIV(base).gets 3492 if {![winfo exists $t]} { 3493 toplevel $t 3494 wm withdraw $t 3495 catch {wm attributes $t -type dialog} 3496 wm title $t "tkcon gets stdin request" 3497 label $t.gets -text "\"gets stdin\" request:" 3498 text $t.data -width 32 -height 5 -wrap none \ 3499 -xscrollcommand [list $t.sx set] \ 3500 -yscrollcommand [list $t.sy set] -borderwidth 1 3501 scrollbar $t.sx -orient h -takefocus 0 -highlightthickness 0 \ 3502 -command [list $t.data xview] 3503 scrollbar $t.sy -orient v -takefocus 0 -highlightthickness 0 \ 3504 -command [list $t.data yview] 3505 button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} 3506 bind $t.ok <Return> { %W invoke } 3507 grid $t.gets - -sticky ew 3508 grid $t.data $t.sy -sticky news 3509 grid $t.sx -sticky ew 3510 grid $t.ok - -sticky ew 3511 grid columnconfig $t 0 -weight 1 3512 grid rowconfig $t 1 -weight 1 3513 wm transient $t $PRIV(root) 3514 wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ 3515 reqwidth $t]) / 2}]+[expr {([winfo \ 3516 screenheight $t]-[winfo reqheight $t]) / 2}] 3517 } 3518 $t.data delete 1.0 end 3519 wm deiconify $t 3520 raise $t 3521 grab $t 3522 focus $t.data 3523 vwait ::tkcon::PRIV(grab) 3524 grab release $t 3525 wm withdraw $t 3526 return [$t.data get 1.0 end-1c] 3527 } 3528 err* { 3529 ## Outputs stack caused by last error. 3530 ## error handling with pizazz (but with pizza would be nice too) 3531 if {[llength $args]==2} { 3532 set app [lindex $args 0] 3533 set type [lindex $args 1] 3534 if {[catch {::tkcon::EvalOther $app $type set errorInfo} info]} { 3535 set info "error getting info from $type $app:\n$info" 3536 } 3537 } else { 3538 set info $PRIV(errorInfo) 3539 } 3540 if {[string match {} $info]} { set info "errorInfo empty" } 3541 ## If args is empty, the -attach switch just ignores it 3542 $OPT(edit) -attach $args -type error -- $info 3543 } 3544 fi* { 3545 ## 'find' string 3546 ::tkcon::Find $PRIV(console) $args 3547 } 3548 fo* { 3549 ## 'font' ?fontname? - gets/sets the font of the console 3550 if {[llength $args]} { 3551 if {[info exists PRIV(console)] && \ 3552 [winfo exists $PRIV(console)]} { 3553 $PRIV(console) config -font $args 3554 set OPT(font) [$PRIV(console) cget -font] 3555 } else { 3556 set OPT(font) $args 3557 } 3558 } 3559 return $OPT(font) 3560 } 3561 hid* - with* { 3562 ## 'hide' 'withdraw' - hides the console. 3563 if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} { 3564 wm withdraw $PRIV(root) 3565 } 3566 } 3567 his* { 3568 ## 'history' 3569 set sub {\2} 3570 if {[string match -new* $args]} { append sub "\n"} 3571 set h [::tkcon::EvalSlave history] 3572 regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h 3573 return $h 3574 } 3575 ico* { 3576 ## 'iconify' - iconifies the console with 'iconify'. 3577 if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} { 3578 wm iconify $PRIV(root) 3579 } 3580 } 3581 mas* - eval { 3582 ## 'master' - evals contents in master interpreter 3583 uplevel \#0 $args 3584 } 3585 result* { 3586 ## 'resultfilter' Sets/queries the result filter command 3587 if {[llength $args]} { 3588 set OPT(resultfilter) $args 3589 } 3590 return $OPT(resultfilter) 3591 } 3592 set { 3593 ## 'set' - set (or get, or unset) simple vars (not whole arrays) 3594 ## from the master console interpreter 3595 ## possible formats: 3596 ## tkcon set <var> 3597 ## tkcon set <var> <value> 3598 ## tkcon set <var> <interp> <var1> <var2> w 3599 ## tkcon set <var> <interp> <var1> <var2> u 3600 ## tkcon set <var> <interp> <var1> <var2> r 3601 if {[llength $args]==5} { 3602 ## This is for use w/ 'tkcon upvar' and only works with slaves 3603 foreach {var i var1 var2 op} $args break 3604 if {[string compare {} $var2]} { append var1 "($var2)" } 3605 switch $op { 3606 u { uplevel \#0 [list unset $var] } 3607 w { 3608 return [uplevel \#0 [list set $var \ 3609 [interp eval $i [list set $var1]]]] 3610 } 3611 r { 3612 return [interp eval $i [list set $var1 \ 3613 [uplevel \#0 [list set $var]]]] 3614 } 3615 } 3616 } elseif {[llength $args] == 1} { 3617 upvar \#0 [lindex $args 0] var 3618 if {[array exists var]} { 3619 return [array get var] 3620 } else { 3621 return $var 3622 } 3623 } 3624 return [uplevel \#0 set $args] 3625 } 3626 append { 3627 ## Modify a var in the master environment using append 3628 return [uplevel \#0 append $args] 3629 } 3630 lappend { 3631 ## Modify a var in the master environment using lappend 3632 return [uplevel \#0 lappend $args] 3633 } 3634 sh* - dei* { 3635 ## 'show|deiconify' - deiconifies the console. 3636 if {![info exists PRIV(root)]} { 3637 # We are likely in some embedded console configuration. 3638 # Make default setup reflect that. 3639 set PRIV(showOnStartup) 0 3640 set PRIV(protocol) {tkcon hide} 3641 set PRIV(root) .tkcon 3642 set OPT(exec) "" 3643 } 3644 if {![winfo exists $PRIV(root)]} { 3645 ::tkcon::Init 3646 } 3647 wm deiconify $PRIV(root) 3648 raise $PRIV(root) 3649 focus -force $PRIV(console) 3650 } 3651 ti* { 3652 ## 'title' ?title? - gets/sets the console's title 3653 if {[llength $args]} { 3654 return [wm title $PRIV(root) [join $args]] 3655 } else { 3656 return [wm title $PRIV(root)] 3657 } 3658 } 3659 upv* { 3660 ## 'upvar' masterVar slaveVar 3661 ## link slave variable slaveVar to the master variable masterVar 3662 ## only works masters<->slave 3663 set masterVar [lindex $args 0] 3664 set slaveVar [lindex $args 1] 3665 if {[info exists $masterVar]} { 3666 interp eval $OPT(exec) \ 3667 [list set $slaveVar [set $masterVar]] 3668 } else { 3669 catch {interp eval $OPT(exec) [list unset $slaveVar]} 3670 } 3671 interp eval $OPT(exec) \ 3672 [list trace variable $slaveVar rwu \ 3673 [list tkcon set $masterVar $OPT(exec)]] 3674 return 3675 } 3676 v* { 3677 return $PRIV(version) 3678 } 3679 default { 3680 ## tries to determine if the command exists, otherwise throws error 3681 set new ::tkcon::[string toupper \ 3682 [string index $cmd 0]][string range $cmd 1 end] 3683 if {[llength [info command $new]]} { 3684 uplevel \#0 $new $args 3685 } else { 3686 return -code error "bad option \"$cmd\": must be\ 3687 [join [lsort [list attach close console destroy \ 3688 font hide iconify load main master new save show \ 3689 slave deiconify version title bgerror]] {, }]" 3690 } 3691 } 3692 } 3693} 3694 3695## 3696## Some procedures to make up for lack of built-in shell commands 3697## 3698 3699## tkcon_puts - 3700## This allows me to capture all stdout/stderr to the console window 3701## This will be renamed to 'puts' at the appropriate time during init 3702## 3703# ARGS: same as usual 3704# Outputs: the string with a color-coded text tag 3705## 3706proc tkcon_puts args { 3707 set len [llength $args] 3708 foreach {arg1 arg2 arg3} $args { break } 3709 3710 if {$len == 1} { 3711 tkcon console insert output "$arg1\n" stdout 3712 } elseif {$len == 2} { 3713 if {![string compare $arg1 -nonewline]} { 3714 tkcon console insert output $arg2 stdout 3715 } elseif {![string compare $arg1 stdout] \ 3716 || ![string compare $arg1 stderr]} { 3717 tkcon console insert output "$arg2\n" $arg1 3718 } else { 3719 set len 0 3720 } 3721 } elseif {$len == 3} { 3722 if {![string compare $arg1 -nonewline] \ 3723 && (![string compare $arg2 stdout] \ 3724 || ![string compare $arg2 stderr])} { 3725 tkcon console insert output $arg3 $arg2 3726 } elseif {(![string compare $arg1 stdout] \ 3727 || ![string compare $arg1 stderr]) \ 3728 && ![string compare $arg3 nonewline]} { 3729 tkcon console insert output $arg2 $arg1 3730 } else { 3731 set len 0 3732 } 3733 } else { 3734 set len 0 3735 } 3736 3737 ## $len == 0 means it wasn't handled by tkcon above. 3738 ## 3739 if {$len == 0} { 3740 global errorCode errorInfo 3741 if {[catch "tkcon_tcl_puts $args" msg]} { 3742 regsub tkcon_tcl_puts $msg puts msg 3743 regsub -all tkcon_tcl_puts $errorInfo puts errorInfo 3744 return -code error $msg 3745 } 3746 return $msg 3747 } 3748 3749 ## WARNING: This update should behave well because it uses idletasks, 3750 ## however, if there are weird looping problems with events, or 3751 ## hanging in waits, try commenting this out. 3752 if {$len} { 3753 tkcon console see output 3754 update idletasks 3755 } 3756} 3757 3758## tkcon_gets - 3759## This allows me to capture all stdin input without needing to stdin 3760## This will be renamed to 'gets' at the appropriate time during init 3761## 3762# ARGS: same as gets 3763# Outputs: same as gets 3764## 3765proc tkcon_gets args { 3766 set len [llength $args] 3767 if {$len != 1 && $len != 2} { 3768 return -code error \ 3769 "wrong # args: should be \"gets channelId ?varName?\"" 3770 } 3771 if {[string compare stdin [lindex $args 0]]} { 3772 return [uplevel 1 tkcon_tcl_gets $args] 3773 } 3774 set gtype [tkcon set ::tkcon::OPT(gets)] 3775 if {$gtype == ""} { set gtype congets } 3776 set data [tkcon $gtype] 3777 if {$len == 2} { 3778 upvar 1 [lindex $args 1] var 3779 set var $data 3780 return [string length $data] 3781 } 3782 return $data 3783} 3784 3785## edit - opens a file/proc/var for reading/editing 3786## 3787# Arguments: 3788# type proc/file/var 3789# what the actual name of the item 3790# Returns: nothing 3791## 3792proc edit {args} { 3793 array set opts {-find {} -type {} -attach {} -wrap {none}} 3794 while {[string match -* [lindex $args 0]]} { 3795 switch -glob -- [lindex $args 0] { 3796 -f* { set opts(-find) [lindex $args 1] } 3797 -a* { set opts(-attach) [lindex $args 1] } 3798 -t* { set opts(-type) [lindex $args 1] } 3799 -w* { set opts(-wrap) [lindex $args 1] } 3800 -- { set args [lreplace $args 0 0]; break } 3801 default {return -code error "unknown option \"[lindex $args 0]\""} 3802 } 3803 set args [lreplace $args 0 1] 3804 } 3805 # determine who we are dealing with 3806 if {[llength $opts(-attach)]} { 3807 foreach {app type} $opts(-attach) {break} 3808 } else { 3809 foreach {app type} [tkcon attach] {break} 3810 } 3811 3812 set word [lindex $args 0] 3813 if {$opts(-type) == {}} { 3814 if {[llength [::tkcon::EvalOther $app $type info commands [list $word]]]} { 3815 set opts(-type) "proc" 3816 } elseif {[llength [::tkcon::EvalOther $app $type info vars [list $word]]]} { 3817 set opts(-type) "var" 3818 } elseif {[::tkcon::EvalOther $app $type file isfile [list $word]]} { 3819 set opts(-type) "file" 3820 } 3821 } 3822 if {$opts(-type) == {}} { 3823 return -code error "unrecognized type '$word'" 3824 } 3825 3826 # Create unique edit window toplevel 3827 set w $::tkcon::PRIV(base).__edit 3828 set i 0 3829 while {[winfo exists $w[incr i]]} {} 3830 append w $i 3831 toplevel $w 3832 wm withdraw $w 3833 if {[string length $word] > 20} { 3834 wm title $w "[string range $word 0 16]... - tkcon Edit" 3835 } else { 3836 wm title $w "$word - tkcon Edit" 3837 } 3838 3839 if {[package provide ctext] != ""} { 3840 set txt [ctext $w.text] 3841 } else { 3842 set txt [text $w.text] 3843 } 3844 $w.text configure -wrap $opts(-wrap) \ 3845 -xscrollcommand [list $w.sx set] \ 3846 -yscrollcommand [list $w.sy set] \ 3847 -foreground $::tkcon::COLOR(stdin) \ 3848 -background $::tkcon::COLOR(bg) \ 3849 -insertbackground $::tkcon::COLOR(cursor) \ 3850 -font $::tkcon::OPT(font) -borderwidth 1 -highlightthickness 0 3851 catch { 3852 # 8.4+ stuff 3853 $w.text configure -undo 1 3854 } 3855 scrollbar $w.sx -orient h -command [list $w.text xview] 3856 scrollbar $w.sy -orient v -command [list $w.text yview] 3857 3858 set menu [menu $w.mbar] 3859 $w configure -menu $menu 3860 3861 ## File Menu 3862 ## 3863 set m [menu [::tkcon::MenuButton $menu File file]] 3864 $m add command -label "Save As..." -underline 0 \ 3865 -command [list ::tkcon::Save {} widget $w.text] 3866 $m add command -label "Append To..." -underline 0 \ 3867 -command [list ::tkcon::Save {} widget $w.text a+] 3868 $m add separator 3869 $m add command -label "Dismiss" -underline 0 -accel "Ctrl-w" \ 3870 -command [list destroy $w] 3871 bind $w <Control-w> [list destroy $w] 3872 bind $w <$::tkcon::PRIV(meta)-w> [list destroy $w] 3873 3874 ## Edit Menu 3875 ## 3876 set text $w.text 3877 set m [menu [::tkcon::MenuButton $menu Edit edit]] 3878 $m add command -label "Cut" -under 2 \ 3879 -command [list tk_textCut $text] 3880 $m add command -label "Copy" -under 0 \ 3881 -command [list tk_textCopy $text] 3882 $m add command -label "Paste" -under 0 \ 3883 -command [list tk_textPaste $text] 3884 $m add separator 3885 $m add command -label "Find" -under 0 \ 3886 -command [list ::tkcon::FindBox $text] 3887 3888 ## Send To Menu 3889 ## 3890 set m [menu [::tkcon::MenuButton $menu "Send To..." send]] 3891 $m add command -label "Send To $app" -underline 0 \ 3892 -command "::tkcon::EvalOther [list $app] $type \ 3893 eval \[$w.text get 1.0 end-1c\]" 3894 set other [tkcon attach] 3895 if {[string compare $other [list $app $type]]} { 3896 $m add command -label "Send To [lindex $other 0]" \ 3897 -command "::tkcon::EvalOther $other \ 3898 eval \[$w.text get 1.0 end-1c\]" 3899 } 3900 3901 grid $w.text - $w.sy -sticky news 3902 grid $w.sx - -sticky ew 3903 grid columnconfigure $w 0 -weight 1 3904 grid columnconfigure $w 1 -weight 1 3905 grid rowconfigure $w 0 -weight 1 3906 3907 switch -glob -- $opts(-type) { 3908 proc* { 3909 $w.text insert 1.0 \ 3910 [::tkcon::EvalOther $app $type dump proc [list $word]] 3911 after idle [::tkcon::Highlight $w.text tcl] 3912 } 3913 var* { 3914 $w.text insert 1.0 \ 3915 [::tkcon::EvalOther $app $type dump var [list $word]] 3916 after idle [::tkcon::Highlight $w.text tcl] 3917 } 3918 file { 3919 $w.text insert 1.0 [::tkcon::EvalOther $app $type eval \ 3920 [subst -nocommands { 3921 set __tkcon(fid) [open {$word} r] 3922 set __tkcon(data) [read \$__tkcon(fid)] 3923 close \$__tkcon(fid) 3924 after 1000 unset __tkcon 3925 return \$__tkcon(data) 3926 } 3927 ]] 3928 after idle [::tkcon::Highlight $w.text \ 3929 [string trimleft [file extension $word] .]] 3930 } 3931 error* { 3932 $w.text insert 1.0 [join $args \n] 3933 after idle [::tkcon::Highlight $w.text error] 3934 } 3935 default { 3936 $w.text insert 1.0 [join $args \n] 3937 } 3938 } 3939 wm deiconify $w 3940 focus $w.text 3941 if {[string compare $opts(-find) {}]} { 3942 ::tkcon::Find $w.text $opts(-find) -case 1 3943 } 3944} 3945interp alias {} ::more {} ::edit 3946interp alias {} ::less {} ::edit 3947 3948## echo 3949## Relaxes the one string restriction of 'puts' 3950# ARGS: any number of strings to output to stdout 3951## 3952proc echo args { puts stdout [concat $args] } 3953 3954## clear - clears the buffer of the console (not the history though) 3955## This is executed in the parent interpreter 3956## 3957proc clear {{pcnt 100}} { 3958 if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { 3959 return -code error \ 3960 "invalid percentage to clear: must be 1-100 (100 default)" 3961 } elseif {$pcnt == 100} { 3962 tkcon console delete 1.0 end 3963 } else { 3964 set tmp [expr {$pcnt/100.0*[tkcon console index end]}] 3965 tkcon console delete 1.0 "$tmp linestart" 3966 } 3967} 3968 3969## alias - akin to the csh alias command 3970## If called with no args, then it dumps out all current aliases 3971## If called with one arg, returns the alias of that arg (or {} if none) 3972# ARGS: newcmd - (optional) command to bind alias to 3973# args - command and args being aliased 3974## 3975proc alias {{newcmd {}} args} { 3976 if {[string match {} $newcmd]} { 3977 set res {} 3978 foreach a [interp aliases] { 3979 lappend res [list $a -> [interp alias {} $a]] 3980 } 3981 return [join $res \n] 3982 } elseif {![llength $args]} { 3983 interp alias {} $newcmd 3984 } else { 3985 eval interp alias [list {} $newcmd {}] $args 3986 } 3987} 3988 3989## unalias - unaliases an alias'ed command 3990# ARGS: cmd - command to unbind as an alias 3991## 3992proc unalias {cmd} { 3993 interp alias {} $cmd {} 3994} 3995 3996## dump - outputs variables/procedure/widget info in source'able form. 3997## Accepts glob style pattern matching for the names 3998# 3999# ARGS: type - type of thing to dump: must be variable, procedure, widget 4000# 4001# OPTS: -nocomplain 4002# don't complain if no items of the specified type are found 4003# -filter pattern 4004# specifies a glob filter pattern to be used by the variable 4005# method as an array filter pattern (it filters down for 4006# nested elements) and in the widget method as a config 4007# option filter pattern 4008# -- forcibly ends options recognition 4009# 4010# Returns: the values of the requested items in a 'source'able form 4011## 4012proc dump {type args} { 4013 set whine 1 4014 set code ok 4015 if {![llength $args]} { 4016 ## If no args, assume they gave us something to dump and 4017 ## we'll try anything 4018 set args $type 4019 set type any 4020 } 4021 while {[string match -* [lindex $args 0]]} { 4022 switch -glob -- [lindex $args 0] { 4023 -n* { set whine 0; set args [lreplace $args 0 0] } 4024 -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } 4025 -- { set args [lreplace $args 0 0]; break } 4026 default {return -code error "unknown option \"[lindex $args 0]\""} 4027 } 4028 } 4029 if {$whine && ![llength $args]} { 4030 return -code error "wrong \# args: [lindex [info level 0] 0] type\ 4031 ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" 4032 } 4033 set res {} 4034 switch -glob -- $type { 4035 c* { 4036 # command 4037 # outputs commands by figuring out, as well as possible, what it is 4038 # this does not attempt to auto-load anything 4039 foreach arg $args { 4040 if {[llength [set cmds [info commands $arg]]]} { 4041 foreach cmd [lsort $cmds] { 4042 if {[lsearch -exact [interp aliases] $cmd] > -1} { 4043 append res "\#\# ALIAS: $cmd =>\ 4044 [interp alias {} $cmd]\n" 4045 } elseif { 4046 [llength [info procs $cmd]] || 4047 ([string match *::* $cmd] && 4048 [llength [namespace eval [namespace qual $cmd] \ 4049 info procs [namespace tail $cmd]]]) 4050 } { 4051 if {[catch {dump p -- $cmd} msg] && $whine} { 4052 set code error 4053 } 4054 append res $msg\n 4055 } else { 4056 append res "\#\# COMMAND: $cmd\n" 4057 } 4058 } 4059 } elseif {$whine} { 4060 append res "\#\# No known command $arg\n" 4061 set code error 4062 } 4063 } 4064 } 4065 v* { 4066 # variable 4067 # outputs variables value(s), whether array or simple. 4068 if {![info exists fltr]} { set fltr * } 4069 foreach arg $args { 4070 if {![llength [set vars [uplevel 1 info vars [list $arg]]]]} { 4071 if {[uplevel 1 info exists $arg]} { 4072 set vars $arg 4073 } elseif {$whine} { 4074 append res "\#\# No known variable $arg\n" 4075 set code error 4076 continue 4077 } else { continue } 4078 } 4079 foreach var [lsort $vars] { 4080 if {[uplevel 1 [list info locals $var]] == ""} { 4081 # use the proper scope of the var, but namespace which 4082 # won't id locals or some upvar'ed vars correctly 4083 set new [uplevel 1 \ 4084 [list namespace which -variable $var]] 4085 if {$new != ""} { 4086 set var $new 4087 } 4088 } 4089 upvar 1 $var v 4090 if {[array exists v] || [catch {string length $v}]} { 4091 set nst {} 4092 append res "array set [list $var] \{\n" 4093 if {[array size v]} { 4094 foreach i \ 4095 [lsort -dictionary [array names v $fltr]] { 4096 upvar 0 v\($i\) __a 4097 if {[array exists __a]} { 4098 append nst "\#\# NESTED ARRAY ELEM: $i\n" 4099 append nst "upvar 0 [list $var\($i\)] __a;\ 4100 [dump v -filter $fltr __a]\n" 4101 } else { 4102 append res " [list $i]\t[list $v($i)]\n" 4103 } 4104 } 4105 } else { 4106 ## empty array 4107 append res " empty array\n" 4108 if {$var == ""} { 4109 append nst "unset (empty)\n" 4110 } else { 4111 append nst "unset [list $var](empty)\n" 4112 } 4113 } 4114 append res "\}\n$nst" 4115 } else { 4116 append res [list set $var $v]\n 4117 } 4118 } 4119 } 4120 } 4121 p* { 4122 # procedure 4123 foreach arg $args { 4124 if { 4125 ![llength [set procs [info proc $arg]]] && 4126 ([string match *::* $arg] && 4127 [llength [set ps [namespace eval \ 4128 [namespace qualifier $arg] \ 4129 info procs [namespace tail $arg]]]]) 4130 } { 4131 set procs {} 4132 set namesp [namespace qualifier $arg] 4133 foreach p $ps { 4134 lappend procs ${namesp}::$p 4135 } 4136 } 4137 if {[llength $procs]} { 4138 foreach p [lsort $procs] { 4139 set as {} 4140 foreach a [info args $p] { 4141 if {[info default $p $a tmp]} { 4142 lappend as [list $a $tmp] 4143 } else { 4144 lappend as $a 4145 } 4146 } 4147 append res [list proc $p $as [info body $p]]\n 4148 } 4149 } elseif {$whine} { 4150 append res "\#\# No known proc $arg\n" 4151 set code error 4152 } 4153 } 4154 } 4155 w* { 4156 # widget 4157 ## The user should have Tk loaded 4158 if {![llength [info command winfo]]} { 4159 return -code error "winfo not present, cannot dump widgets" 4160 } 4161 if {![info exists fltr]} { set fltr .* } 4162 foreach arg $args { 4163 if {[llength [set ws [info command $arg]]]} { 4164 foreach w [lsort $ws] { 4165 if {[winfo exists $w]} { 4166 if {[catch {$w configure} cfg]} { 4167 append res "\#\# Widget $w\ 4168 does not support configure method" 4169 set code error 4170 } else { 4171 append res "\#\# [winfo class $w]\ 4172 $w\n$w configure" 4173 foreach c $cfg { 4174 if {[llength $c] != 5} continue 4175 ## Check to see that the option does 4176 ## not match the default, then check 4177 ## the item against the user filter 4178 if {[string compare [lindex $c 3] \ 4179 [lindex $c 4]] && \ 4180 [regexp -nocase -- $fltr $c]} { 4181 append res " \\\n\t[list [lindex $c 0]\ 4182 [lindex $c 4]]" 4183 } 4184 } 4185 append res \n 4186 } 4187 } 4188 } 4189 } elseif {$whine} { 4190 append res "\#\# No known widget $arg\n" 4191 set code error 4192 } 4193 } 4194 } 4195 a* { 4196 ## see if we recognize it, other complain 4197 if {[regexp {(var|com|proc|widget)} \ 4198 [set types [uplevel 1 what $args]]]} { 4199 foreach type $types { 4200 if {[regexp {(var|com|proc|widget)} $type]} { 4201 append res "[uplevel 1 dump $type $args]\n" 4202 } 4203 } 4204 } else { 4205 set res "dump was unable to resolve type for \"$args\"" 4206 set code error 4207 } 4208 } 4209 default { 4210 return -code error "bad [lindex [info level 0] 0] option\ 4211 \"$type\": must be variable, command, procedure,\ 4212 or widget" 4213 } 4214 } 4215 return -code $code [string trimright $res \n] 4216} 4217 4218## idebug - interactive debugger 4219# 4220# idebug body ?level? 4221# 4222# Prints out the body of the command (if it is a procedure) at the 4223# specified level. <i>level</i> defaults to the current level. 4224# 4225# idebug break 4226# 4227# Creates a breakpoint within a procedure. This will only trigger 4228# if idebug is on and the id matches the pattern. If so, TkCon will 4229# pop to the front with the prompt changed to an idebug prompt. You 4230# are given the basic ability to observe the call stack an query/set 4231# variables or execute Tcl commands at any level. A separate history 4232# is maintained in debugging mode. 4233# 4234# idebug echo|{echo ?id?} ?args? 4235# 4236# Behaves just like "echo", but only triggers when idebug is on. 4237# You can specify an optional id to further restrict triggering. 4238# If no id is specified, it defaults to the name of the command 4239# in which the call was made. 4240# 4241# idebug id ?id? 4242# 4243# Query or set the idebug id. This id is used by other idebug 4244# methods to determine if they should trigger or not. The idebug 4245# id can be a glob pattern and defaults to *. 4246# 4247# idebug off 4248# 4249# Turns idebug off. 4250# 4251# idebug on ?id? 4252# 4253# Turns idebug on. If 'id' is specified, it sets the id to it. 4254# 4255# idebug puts|{puts ?id?} args 4256# 4257# Behaves just like "puts", but only triggers when idebug is on. 4258# You can specify an optional id to further restrict triggering. 4259# If no id is specified, it defaults to the name of the command 4260# in which the call was made. 4261# 4262# idebug show type ?level? ?VERBOSE? 4263# 4264# 'type' must be one of vars, locals or globals. This method 4265# will output the variables/locals/globals present in a particular 4266# level. If VERBOSE is added, then it actually 'dump's out the 4267# values as well. 'level' defaults to the level in which this 4268# method was called. 4269# 4270# idebug trace ?level? 4271# 4272# Prints out the stack trace from the specified level up to the top 4273# level. 'level' defaults to the current level. 4274# 4275## 4276proc idebug {opt args} { 4277 global IDEBUG 4278 4279 if {![info exists IDEBUG(on)]} { 4280 array set IDEBUG { on 0 id * debugging 0 } 4281 } 4282 set level [expr {[info level]-1}] 4283 switch -glob -- $opt { 4284 on { 4285 if {[llength $args]} { set IDEBUG(id) $args } 4286 return [set IDEBUG(on) 1] 4287 } 4288 off { return [set IDEBUG(on) 0] } 4289 id { 4290 if {![llength $args]} { 4291 return $IDEBUG(id) 4292 } else { return [set IDEBUG(id) $args] } 4293 } 4294 break { 4295 if {!$IDEBUG(on) || $IDEBUG(debugging) || \ 4296 ([llength $args] && \ 4297 ![string match $IDEBUG(id) $args]) || [info level]<1} { 4298 return 4299 } 4300 set IDEBUG(debugging) 1 4301 puts stderr "idebug at level \#$level: [lindex [info level -1] 0]" 4302 set tkcon [llength [info command tkcon]] 4303 if {$tkcon} { 4304 tkcon master eval set ::tkcon::OPT(prompt2) \$::tkcon::OPT(prompt1) 4305 tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(debugPrompt) 4306 set slave [tkcon set ::tkcon::OPT(exec)] 4307 set event [tkcon set ::tkcon::PRIV(event)] 4308 tkcon set ::tkcon::OPT(exec) [tkcon master interp create debugger] 4309 tkcon set ::tkcon::PRIV(event) 1 4310 } 4311 set max $level 4312 while 1 { 4313 set err {} 4314 if {$tkcon} { 4315 # tkcon's overload of gets is advanced enough to not need 4316 # this, but we get a little better control this way. 4317 tkcon evalSlave set level $level 4318 tkcon prompt 4319 set line [tkcon getcommand] 4320 tkcon console mark set output end 4321 } else { 4322 puts -nonewline stderr "(level \#$level) debug > " 4323 gets stdin line 4324 while {![info complete $line]} { 4325 puts -nonewline "> " 4326 append line "\n[gets stdin]" 4327 } 4328 } 4329 if {[string match {} $line]} continue 4330 set key [lindex $line 0] 4331 if {![regexp {^([#-]?[0-9]+)} [lreplace $line 0 0] lvl]} { 4332 set lvl \#$level 4333 } 4334 set res {}; set c 0 4335 switch -- $key { 4336 + { 4337 ## Allow for jumping multiple levels 4338 if {$level < $max} { 4339 idebug trace [incr level] $level 0 VERBOSE 4340 } 4341 } 4342 - { 4343 ## Allow for jumping multiple levels 4344 if {$level > 1} { 4345 idebug trace [incr level -1] $level 0 VERBOSE 4346 } 4347 } 4348 . { set c [catch {idebug trace $level $level 0 VERBOSE} res] } 4349 v { set c [catch {idebug show vars $lvl } res] } 4350 V { set c [catch {idebug show vars $lvl VERBOSE} res] } 4351 l { set c [catch {idebug show locals $lvl } res] } 4352 L { set c [catch {idebug show locals $lvl VERBOSE} res] } 4353 g { set c [catch {idebug show globals $lvl } res] } 4354 G { set c [catch {idebug show globals $lvl VERBOSE} res] } 4355 t { set c [catch {idebug trace 1 $max $level } res] } 4356 T { set c [catch {idebug trace 1 $max $level VERBOSE} res]} 4357 b { set c [catch {idebug body $lvl} res] } 4358 o { set res [set IDEBUG(on) [expr {!$IDEBUG(on)}]] } 4359 h - ? { 4360 puts stderr " + Move down in call stack 4361 - Move up in call stack 4362 . Show current proc name and params 4363 4364 v Show names of variables currently in scope 4365 V Show names of variables currently in scope with values 4366 l Show names of local (transient) variables 4367 L Show names of local (transient) variables with values 4368 g Show names of declared global variables 4369 G Show names of declared global variables with values 4370 t Show a stack trace 4371 T Show a verbose stack trace 4372 4373 b Show body of current proc 4374 o Toggle on/off any further debugging 4375 c,q Continue regular execution (Quit debugger) 4376 h,? Print this help 4377 default Evaluate line at current level (\#$level)" 4378 } 4379 c - q break 4380 default { set c [catch {uplevel \#$level $line} res] } 4381 } 4382 if {$tkcon} { 4383 tkcon set ::tkcon::PRIV(event) \ 4384 [tkcon evalSlave eval history add [list $line]\ 4385 \; history nextid] 4386 } 4387 if {$c} { 4388 puts stderr $res 4389 } elseif {[string compare {} $res]} { 4390 puts $res 4391 } 4392 } 4393 set IDEBUG(debugging) 0 4394 if {$tkcon} { 4395 tkcon master interp delete debugger 4396 tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(prompt2) 4397 tkcon set ::tkcon::OPT(exec) $slave 4398 tkcon set ::tkcon::PRIV(event) $event 4399 tkcon prompt 4400 } 4401 } 4402 bo* { 4403 if {[regexp {^([#-]?[0-9]+)} $args level]} { 4404 return [uplevel $level {dump c -no [lindex [info level 0] 0]}] 4405 } 4406 } 4407 t* { 4408 if {[llength $args]<2} return 4409 set min [set max [set lvl $level]] 4410 set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?} 4411 if {![regexp $exp $args junk min max lvl verbose]} return 4412 for {set i $max} { 4413 $i>=$min && ![catch {uplevel \#$i info level 0} info] 4414 } {incr i -1} { 4415 if {$i==$lvl} { 4416 puts -nonewline stderr "* \#$i:\t" 4417 } else { 4418 puts -nonewline stderr " \#$i:\t" 4419 } 4420 set name [lindex $info 0] 4421 if {[string compare VERBOSE $verbose] || \ 4422 ![llength [info procs $name]]} { 4423 puts $info 4424 } else { 4425 puts "proc $name {[info args $name]} { ... }" 4426 set idx 0 4427 foreach arg [info args $name] { 4428 if {[string match args $arg]} { 4429 puts "\t$arg = [lrange $info [incr idx] end]" 4430 break 4431 } else { 4432 puts "\t$arg = [lindex $info [incr idx]]" 4433 } 4434 } 4435 } 4436 } 4437 } 4438 s* { 4439 #var, local, global 4440 set level \#$level 4441 if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \ 4442 $args junk type level verbose]} return 4443 switch -glob -- $type { 4444 v* { set vars [uplevel $level {lsort [info vars]}] } 4445 l* { set vars [uplevel $level {lsort [info locals]}] } 4446 g* { set vars [lremove [uplevel $level {info vars}] \ 4447 [uplevel $level {info locals}]] } 4448 } 4449 if {[string match VERBOSE $verbose]} { 4450 return [uplevel $level dump var -nocomplain $vars] 4451 } else { 4452 return $vars 4453 } 4454 } 4455 e* - pu* { 4456 if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} { 4457 set id [lindex [info level 0] 0] 4458 } else { 4459 set id [lindex $opt 1] 4460 } 4461 if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} { 4462 if {[string match e* $opt]} { 4463 puts [concat $args] 4464 } else { eval puts $args } 4465 } 4466 } 4467 default { 4468 return -code error "bad [lindex [info level 0] 0] option \"$opt\",\ 4469 must be: [join [lsort [list on off id break print body\ 4470 trace show puts echo]] {, }]" 4471 } 4472 } 4473} 4474 4475## observe - like trace, but not 4476# ARGS: opt - option 4477# name - name of variable or command 4478## 4479proc observe {opt name args} { 4480 global tcl_observe 4481 switch -glob -- $opt { 4482 co* { 4483 if {[regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} \ 4484 $name]} { 4485 return -code error "cannot observe \"$name\":\ 4486 infinite eval loop will occur" 4487 } 4488 set old ${name}@ 4489 while {[llength [info command $old]]} { append old @ } 4490 rename $name $old 4491 set max 4 4492 regexp {^[0-9]+} $args max 4493 # handle the observe'ing of 'proc' 4494 set proccmd "proc" 4495 if {[string match "proc" $name]} { set proccmd $old } 4496 ## idebug trace could be used here 4497 $proccmd $name args " 4498 for {set i \[info level\]; set max \[expr \[info level\]-$max\]} { 4499 \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\] 4500 } {incr i -1} { 4501 puts -nonewline stderr \" \#\$i:\t\" 4502 puts \$info 4503 } 4504 uplevel \[lreplace \[info level 0\] 0 0 $old\] 4505 " 4506 set tcl_observe($name) $old 4507 } 4508 cd* { 4509 if {[info exists tcl_observe($name)] && [catch { 4510 rename $name {} 4511 rename $tcl_observe($name) $name 4512 unset tcl_observe($name) 4513 } err]} { return -code error $err } 4514 } 4515 ci* { 4516 ## What a useless method... 4517 if {[info exists tcl_observe($name)]} { 4518 set i $tcl_observe($name) 4519 set res "\"$name\" observes true command \"$i\"" 4520 while {[info exists tcl_observe($i)]} { 4521 append res "\n\"$name\" observes true command \"$i\"" 4522 set i $tcl_observe($name) 4523 } 4524 return $res 4525 } 4526 } 4527 va* - vd* { 4528 set type [lindex $args 0] 4529 set args [lrange $args 1 end] 4530 if {![regexp {^[rwu]} $type type]} { 4531 return -code error "bad [lindex [info level 0] 0] $opt type\ 4532 \"$type\", must be: read, write or unset" 4533 } 4534 if {![llength $args]} { set args observe_var } 4535 foreach c [uplevel 1 [list trace vinfo $name]] { 4536 # don't double up on the traces 4537 if {[list $type $args] == $c} { return } 4538 } 4539 uplevel 1 [list trace $opt $name $type $args] 4540 } 4541 vi* { 4542 uplevel 1 [list trace vinfo $name] 4543 } 4544 default { 4545 return -code error "bad [lindex [info level 0] 0] option\ 4546 \"[lindex $args 0]\", must be: [join [lsort \ 4547 [list command cdelete cinfo variable vdelete vinfo]] {, }]" 4548 } 4549 } 4550} 4551 4552## observe_var - auxilary function for observing vars, called by trace 4553## via observe 4554# ARGS: name - variable name 4555# el - array element name, if any 4556# op - operation type (rwu) 4557## 4558proc observe_var {name el op} { 4559 if {[string match u $op]} { 4560 if {[string compare {} $el]} { 4561 puts "unset \"${name}($el)\"" 4562 } else { 4563 puts "unset \"$name\"" 4564 } 4565 } else { 4566 upvar 1 $name $name 4567 if {[info exists ${name}($el)]} { 4568 puts [dump v ${name}($el)] 4569 } else { 4570 puts [dump v $name] 4571 } 4572 } 4573} 4574 4575## which - tells you where a command is found 4576# ARGS: cmd - command name 4577# Returns: where command is found (internal / external / unknown) 4578## 4579proc which cmd { 4580 ## This tries to auto-load a command if not recognized 4581 set types [uplevel 1 [list what $cmd 1]] 4582 if {[llength $types]} { 4583 set out {} 4584 4585 foreach type $types { 4586 switch -- $type { 4587 alias { set res "$cmd: aliased to [alias $cmd]" } 4588 procedure { set res "$cmd: procedure" } 4589 command { set res "$cmd: internal command" } 4590 executable { lappend out [auto_execok $cmd] } 4591 variable { lappend out "$cmd: $type" } 4592 } 4593 if {[info exists res]} { 4594 global auto_index 4595 if {[info exists auto_index($cmd)]} { 4596 ## This tells you where the command MIGHT have come from - 4597 ## not true if the command was redefined interactively or 4598 ## existed before it had to be auto_loaded. This is just 4599 ## provided as a hint at where it MAY have come from 4600 append res " ($auto_index($cmd))" 4601 } 4602 lappend out $res 4603 unset res 4604 } 4605 } 4606 return [join $out \n] 4607 } else { 4608 return -code error "$cmd: command not found" 4609 } 4610} 4611 4612## what - tells you what a string is recognized as 4613# ARGS: str - string to id 4614# Returns: id types of command as list 4615## 4616proc what {str {autoload 0}} { 4617 set types {} 4618 if {[llength [info commands $str]] || ($autoload && \ 4619 [auto_load $str] && [llength [info commands $str]])} { 4620 if {[lsearch -exact [interp aliases] $str] > -1} { 4621 lappend types "alias" 4622 } elseif { 4623 [llength [info procs $str]] || 4624 ([string match *::* $str] && 4625 [llength [namespace eval [namespace qualifier $str] \ 4626 info procs [namespace tail $str]]]) 4627 } { 4628 lappend types "procedure" 4629 } else { 4630 lappend types "command" 4631 } 4632 } 4633 if {[llength [uplevel 1 info vars $str]]} { 4634 upvar 1 $str var 4635 if {[array exists var]} { 4636 lappend types array variable 4637 } else { 4638 lappend types scalar variable 4639 } 4640 } 4641 if {[file isdirectory $str]} { 4642 lappend types "directory" 4643 } 4644 if {[file isfile $str]} { 4645 lappend types "file" 4646 } 4647 if {[llength [info commands winfo]] && [winfo exists $str]} { 4648 lappend types "widget" 4649 } 4650 if {[string compare {} [auto_execok $str]]} { 4651 lappend types "executable" 4652 } 4653 return $types 4654} 4655 4656## dir - directory list 4657# ARGS: args - names/glob patterns of directories to list 4658# OPTS: -all - list hidden files as well (Unix dot files) 4659# -long - list in full format "permissions size date filename" 4660# -full - displays / after directories and link paths for links 4661# Returns: a directory listing 4662## 4663proc dir {args} { 4664 array set s { 4665 all 0 full 0 long 0 4666 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx 4667 } 4668 while {[string match \-* [lindex $args 0]]} { 4669 set str [lindex $args 0] 4670 set args [lreplace $args 0 0] 4671 switch -glob -- $str { 4672 -a* {set s(all) 1} -f* {set s(full) 1} 4673 -l* {set s(long) 1} -- break 4674 default { 4675 return -code error "unknown option \"$str\",\ 4676 should be one of: -all, -full, -long" 4677 } 4678 } 4679 } 4680 set sep [string trim [file join . .] .] 4681 if {![llength $args]} { set args [list [pwd]] } 4682 if {$::tcl_version >= 8.3} { 4683 # Newer glob args allow safer dir processing. The user may still 4684 # want glob chars, but really only for file matching. 4685 foreach arg $args { 4686 if {[file isdirectory $arg]} { 4687 if {$s(all)} { 4688 lappend out [list $arg [lsort \ 4689 [glob -nocomplain -directory $arg .* *]]] 4690 } else { 4691 lappend out [list $arg [lsort \ 4692 [glob -nocomplain -directory $arg *]]] 4693 } 4694 } else { 4695 set dir [file dirname $arg] 4696 lappend out [list $dir$sep [lsort \ 4697 [glob -nocomplain -directory $dir [file tail $arg]]]] 4698 } 4699 } 4700 } else { 4701 foreach arg $args { 4702 if {[file isdirectory $arg]} { 4703 set arg [string trimright $arg $sep]$sep 4704 if {$s(all)} { 4705 lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] 4706 } else { 4707 lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] 4708 } 4709 } else { 4710 lappend out [list [file dirname $arg]$sep \ 4711 [lsort [glob -nocomplain -- $arg]]] 4712 } 4713 } 4714 } 4715 if {$s(long)} { 4716 set old [clock scan {1 year ago}] 4717 set fmt "%s%9ld %s %s\n" 4718 foreach o $out { 4719 set d [lindex $o 0] 4720 append res $d:\n 4721 foreach f [lindex $o 1] { 4722 file lstat $f st 4723 set f [file tail $f] 4724 if {$s(full)} { 4725 switch -glob $st(type) { 4726 d* { append f $sep } 4727 l* { append f "@ -> [file readlink $d$sep$f]" } 4728 default { if {[file exec $d$sep$f]} { append f * } } 4729 } 4730 } 4731 if {[string match file $st(type)]} { 4732 set mode - 4733 } else { 4734 set mode [string index $st(type) 0] 4735 } 4736 foreach j [split [format %03o [expr {$st(mode)&0777}]] {}] { 4737 append mode $s($j) 4738 } 4739 if {$st(mtime)>$old} { 4740 set cfmt {%b %d %H:%M} 4741 } else { 4742 set cfmt {%b %d %Y} 4743 } 4744 append res [format $fmt $mode $st(size) \ 4745 [clock format $st(mtime) -format $cfmt] $f] 4746 } 4747 append res \n 4748 } 4749 } else { 4750 foreach o $out { 4751 set d [lindex $o 0] 4752 append res "$d:\n" 4753 set i 0 4754 foreach f [lindex $o 1] { 4755 if {[string len [file tail $f]] > $i} { 4756 set i [string len [file tail $f]] 4757 } 4758 } 4759 set i [expr {$i+2+$s(full)}] 4760 set j 80 4761 ## This gets the number of cols in the tkcon console widget 4762 if {[llength [info commands tkcon]]} { 4763 set j [expr {[tkcon master set ::tkcon::OPT(cols)]/$i}] 4764 } 4765 set k 0 4766 foreach f [lindex $o 1] { 4767 set f [file tail $f] 4768 if {$s(full)} { 4769 switch -glob [file type $d$sep$f] { 4770 d* { append f $sep } 4771 l* { append f @ } 4772 default { if {[file exec $d$sep$f]} { append f * } } 4773 } 4774 } 4775 append res [format "%-${i}s" $f] 4776 if {$j == 0 || [incr k]%$j == 0} { 4777 set res [string trimright $res]\n 4778 } 4779 } 4780 append res \n\n 4781 } 4782 } 4783 return [string trimright $res] 4784} 4785interp alias {} ::ls {} ::dir -full 4786 4787## lremove - remove items from a list 4788# OPTS: 4789# -all remove all instances of each item 4790# -glob remove all instances matching glob pattern 4791# -regexp remove all instances matching regexp pattern 4792# ARGS: l a list to remove items from 4793# args items to remove (these are 'join'ed together) 4794## 4795proc lremove {args} { 4796 array set opts {-all 0 pattern -exact} 4797 while {[string match -* [lindex $args 0]]} { 4798 switch -glob -- [lindex $args 0] { 4799 -a* { set opts(-all) 1 } 4800 -g* { set opts(pattern) -glob } 4801 -r* { set opts(pattern) -regexp } 4802 -- { set args [lreplace $args 0 0]; break } 4803 default {return -code error "unknown option \"[lindex $args 0]\""} 4804 } 4805 set args [lreplace $args 0 0] 4806 } 4807 set l [lindex $args 0] 4808 foreach i [join [lreplace $args 0 0]] { 4809 if {[set ix [lsearch $opts(pattern) $l $i]] == -1} continue 4810 set l [lreplace $l $ix $ix] 4811 if {$opts(-all)} { 4812 while {[set ix [lsearch $opts(pattern) $l $i]] != -1} { 4813 set l [lreplace $l $ix $ix] 4814 } 4815 } 4816 } 4817 return $l 4818} 4819 4820if {!$::tkcon::PRIV(WWW)} {; 4821 4822## Unknown changed to get output into tkcon window 4823# unknown: 4824# Invoked automatically whenever an unknown command is encountered. 4825# Works through a list of "unknown handlers" that have been registered 4826# to deal with unknown commands. Extensions can integrate their own 4827# handlers into the 'unknown' facility via 'unknown_handler'. 4828# 4829# If a handler exists that recognizes the command, then it will 4830# take care of the command action and return a valid result or a 4831# Tcl error. Otherwise, it should return "-code continue" (=2) 4832# and responsibility for the command is passed to the next handler. 4833# 4834# Arguments: 4835# args - A list whose elements are the words of the original 4836# command, including the command name. 4837 4838proc unknown args { 4839 global unknown_handler_order unknown_handlers errorInfo errorCode 4840 4841 # 4842 # Be careful to save error info now, and restore it later 4843 # for each handler. Some handlers generate their own errors 4844 # and disrupt handling. 4845 # 4846 set savedErrorCode $errorCode 4847 set savedErrorInfo $errorInfo 4848 4849 if {![info exists unknown_handler_order] || \ 4850 ![info exists unknown_handlers]} { 4851 set unknown_handlers(tcl) tcl_unknown 4852 set unknown_handler_order tcl 4853 } 4854 4855 foreach handler $unknown_handler_order { 4856 set status [catch {uplevel 1 $unknown_handlers($handler) $args} result] 4857 4858 if {$status == 1} { 4859 # 4860 # Strip the last five lines off the error stack (they're 4861 # from the "uplevel" command). 4862 # 4863 set new [split $errorInfo \n] 4864 set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n] 4865 return -code $status -errorcode $errorCode \ 4866 -errorinfo $new $result 4867 4868 } elseif {$status != 4} { 4869 return -code $status $result 4870 } 4871 4872 set errorCode $savedErrorCode 4873 set errorInfo $savedErrorInfo 4874 } 4875 4876 set name [lindex $args 0] 4877 return -code error "invalid command name \"$name\"" 4878} 4879 4880# tcl_unknown: 4881# Invoked when a Tcl command is invoked that doesn't exist in the 4882# interpreter: 4883# 4884# 1. See if the autoload facility can locate the command in a 4885# Tcl script file. If so, load it and execute it. 4886# 2. If the command was invoked interactively at top-level: 4887# (a) see if the command exists as an executable UNIX program. 4888# If so, "exec" the command. 4889# (b) see if the command requests csh-like history substitution 4890# in one of the common forms !!, !<number>, or ^old^new. If 4891# so, emulate csh's history substitution. 4892# (c) see if the command is a unique abbreviation for another 4893# command. If so, invoke the command. 4894# 4895# Arguments: 4896# args - A list whose elements are the words of the original 4897# command, including the command name. 4898 4899proc tcl_unknown args { 4900 global auto_noexec auto_noload env unknown_pending tcl_interactive 4901 global errorCode errorInfo 4902 4903 # If the command word has the form "namespace inscope ns cmd" 4904 # then concatenate its arguments onto the end and evaluate it. 4905 4906 set cmd [lindex $args 0] 4907 if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \ 4908 && [llength $cmd] == 4} { 4909 set arglist [lrange $args 1 end] 4910 set ret [catch {uplevel 1 $cmd $arglist} result] 4911 if {$ret == 0} { 4912 return $result 4913 } else { 4914 return -code $ret -errorcode $errorCode $result 4915 } 4916 } 4917 4918 # Save the values of errorCode and errorInfo variables, since they 4919 # may get modified if caught errors occur below. The variables will 4920 # be restored just before re-executing the missing command. 4921 4922 set savedErrorCode $errorCode 4923 set savedErrorInfo $errorInfo 4924 set name [lindex $args 0] 4925 if {![info exists auto_noload]} { 4926 # 4927 # Make sure we're not trying to load the same proc twice. 4928 # 4929 if {[info exists unknown_pending($name)]} { 4930 return -code error "self-referential recursion in \"unknown\" for command \"$name\"" 4931 } 4932 set unknown_pending($name) pending 4933 if {[llength [info args auto_load]]==1} { 4934 set ret [catch {auto_load $name} msg] 4935 } else { 4936 set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg] 4937 } 4938 unset unknown_pending($name) 4939 if {$ret} { 4940 return -code $ret -errorcode $errorCode \ 4941 "error while autoloading \"$name\": $msg" 4942 } 4943 if {![array size unknown_pending]} { unset unknown_pending } 4944 if {$msg} { 4945 set errorCode $savedErrorCode 4946 set errorInfo $savedErrorInfo 4947 set code [catch {uplevel 1 $args} msg] 4948 if {$code == 1} { 4949 # 4950 # Strip the last five lines off the error stack (they're 4951 # from the "uplevel" command). 4952 # 4953 4954 set new [split $errorInfo \n] 4955 set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n] 4956 return -code error -errorcode $errorCode \ 4957 -errorinfo $new $msg 4958 } else { 4959 return -code $code $msg 4960 } 4961 } 4962 } 4963 if {[info level] == 1 && [string match {} [info script]] \ 4964 && [info exists tcl_interactive] && $tcl_interactive} { 4965 if {![info exists auto_noexec]} { 4966 set new [auto_execok $name] 4967 if {[string compare {} $new]} { 4968 set errorCode $savedErrorCode 4969 set errorInfo $savedErrorInfo 4970 if {[info exists ::tkcon::EXPECT] && $::tkcon::EXPECT && [package provide Expect] != ""} { 4971 return [tkcon expect [concat $new [lrange $args 1 end]]] 4972 } else { 4973 return [uplevel 1 exec $new [lrange $args 1 end]] 4974 } 4975 #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] 4976 } 4977 } 4978 set errorCode $savedErrorCode 4979 set errorInfo $savedErrorInfo 4980 ## 4981 ## History substitution moved into ::tkcon::EvalCmd 4982 ## 4983 if {[string compare $name "::"] == 0} { 4984 set name "" 4985 } 4986 if {$ret != 0} { 4987 return -code $ret -errorcode $errorCode \ 4988 "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" 4989 } 4990 set cmds [info commands $name*] 4991 if {[llength $cmds] == 1} { 4992 return [uplevel 1 [lreplace $args 0 0 $cmds]] 4993 } 4994 if {[llength $cmds]} { 4995 if {$name == ""} { 4996 return -code error "empty command name \"\"" 4997 } else { 4998 return -code error \ 4999 "ambiguous command name \"$name\": [lsort $cmds]" 5000 } 5001 } 5002 ## We've got nothing so far 5003 ## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd 5004 if {![uplevel \#0 info exists tk_version]} { 5005 lappend tkcmds bell bind bindtags button \ 5006 canvas checkbutton clipboard destroy \ 5007 entry event focus font frame grab grid image \ 5008 label labelframe listbox lower menu menubutton message \ 5009 option pack panedwindow place radiobutton raise \ 5010 scale scrollbar selection send spinbox \ 5011 text tk tkwait toplevel winfo wm 5012 if {[lsearch -exact $tkcmds $name] >= 0 && \ 5013 [tkcon master tk_messageBox -icon question -parent . \ 5014 -title "Load Tk?" -type retrycancel -default retry \ 5015 -message "This appears to be a Tk command, but Tk\ 5016 has not yet been loaded. Shall I retry the command\ 5017 with loading Tk first?"] == "retry"} { 5018 return [uplevel 1 "load {} Tk; $args"] 5019 } 5020 } 5021 } 5022 return -code continue 5023} 5024 5025} ; # end exclusionary code for WWW 5026 5027proc ::tkcon::Bindings {} { 5028 variable PRIV 5029 global tcl_platform tk_version 5030 5031 #----------------------------------------------------------------------- 5032 # Elements of tk::Priv that are used in this file: 5033 # 5034 # mouseMoved - Non-zero means the mouse has moved a significant 5035 # amount since the button went down (so, for example, 5036 # start dragging out a selection). 5037 #----------------------------------------------------------------------- 5038 5039 switch -glob $tcl_platform(platform) { 5040 win* { set PRIV(meta) Alt } 5041 mac* { set PRIV(meta) Command } 5042 default { set PRIV(meta) Meta } 5043 } 5044 5045 ## Get all Text bindings into TkConsole 5046 foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] } 5047 ## We really didn't want the newline insertion 5048 bind TkConsole <Control-Key-o> {} 5049 5050 ## Now make all our virtual event bindings 5051 foreach {ev key} [subst -nocommand -noback { 5052 <<TkCon_Exit>> <Control-q> 5053 <<TkCon_New>> <Control-N> 5054 <<TkCon_NewTab>> <Control-T> 5055 <<TkCon_NextTab>> <Control-Key-Tab> 5056 <<TkCon_PrevTab>> <Control-Shift-Key-Tab> 5057 <<TkCon_Close>> <Control-w> 5058 <<TkCon_About>> <Control-A> 5059 <<TkCon_Help>> <Control-H> 5060 <<TkCon_Find>> <Control-F> 5061 <<TkCon_Slave>> <Control-Key-1> 5062 <<TkCon_Master>> <Control-Key-2> 5063 <<TkCon_Main>> <Control-Key-3> 5064 <<TkCon_Expand>> <Key-Tab> 5065 <<TkCon_ExpandFile>> <Key-Escape> 5066 <<TkCon_ExpandProc>> <Control-P> 5067 <<TkCon_ExpandVar>> <Control-V> 5068 <<TkCon_Tab>> <Control-i> 5069 <<TkCon_Tab>> <$PRIV(meta)-i> 5070 <<TkCon_Newline>> <Control-o> 5071 <<TkCon_Newline>> <$PRIV(meta)-o> 5072 <<TkCon_Newline>> <Control-Key-Return> 5073 <<TkCon_Newline>> <Control-Key-KP_Enter> 5074 <<TkCon_Eval>> <Return> 5075 <<TkCon_Eval>> <KP_Enter> 5076 <<TkCon_Clear>> <Control-l> 5077 <<TkCon_Previous>> <Up> 5078 <<TkCon_PreviousImmediate>> <Control-p> 5079 <<TkCon_PreviousSearch>> <Control-r> 5080 <<TkCon_Next>> <Down> 5081 <<TkCon_NextImmediate>> <Control-n> 5082 <<TkCon_NextSearch>> <Control-s> 5083 <<TkCon_Transpose>> <Control-t> 5084 <<TkCon_ClearLine>> <Control-u> 5085 <<TkCon_SaveCommand>> <Control-z> 5086 <<TkCon_Popup>> <Button-3> 5087 }] { 5088 event add $ev $key 5089 ## Make sure the specific key won't be defined 5090 bind TkConsole $key {} 5091 } 5092 5093 ## Make the ROOT bindings 5094 bind $PRIV(root) <<TkCon_Exit>> exit 5095 bind $PRIV(root) <<TkCon_New>> { ::tkcon::New } 5096 bind $PRIV(root) <<TkCon_NewTab>> { ::tkcon::NewTab } 5097 bind $PRIV(root) <<TkCon_NextTab>> { ::tkcon::GotoTab 1 ; break } 5098 bind $PRIV(root) <<TkCon_PrevTab>> { ::tkcon::GotoTab -1 ; break } 5099 bind $PRIV(root) <<TkCon_Close>> { ::tkcon::Destroy } 5100 bind $PRIV(root) <<TkCon_About>> { ::tkcon::About } 5101 bind $PRIV(root) <<TkCon_Help>> { ::tkcon::Help } 5102 bind $PRIV(root) <<TkCon_Find>> { ::tkcon::FindBox $::tkcon::PRIV(console) } 5103 bind $PRIV(root) <<TkCon_Slave>> { 5104 ::tkcon::Attach {} 5105 ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] 5106 } 5107 bind $PRIV(root) <<TkCon_Master>> { 5108 if {[string compare {} $::tkcon::PRIV(name)]} { 5109 ::tkcon::Attach $::tkcon::PRIV(name) 5110 } else { 5111 ::tkcon::Attach Main 5112 } 5113 ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] 5114 } 5115 bind $PRIV(root) <<TkCon_Main>> { 5116 ::tkcon::Attach Main 5117 ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] 5118 } 5119 bind $PRIV(root) <<TkCon_Popup>> { 5120 ::tkcon::PopupMenu %X %Y 5121 } 5122 5123 ## Menu items need null TkConsolePost bindings to avoid the TagProc 5124 ## 5125 foreach ev [bind $PRIV(root)] { 5126 bind TkConsolePost $ev { 5127 # empty 5128 } 5129 } 5130 5131 5132 # ::tkcon::ClipboardKeysyms -- 5133 # This procedure is invoked to identify the keys that correspond to 5134 # the copy, cut, and paste functions for the clipboard. 5135 # 5136 # Arguments: 5137 # copy - Name of the key (keysym name plus modifiers, if any, 5138 # such as "Meta-y") used for the copy operation. 5139 # cut - Name of the key used for the cut operation. 5140 # paste - Name of the key used for the paste operation. 5141 5142 proc ::tkcon::ClipboardKeysyms {copy cut paste} { 5143 bind TkConsole <$copy> {::tkcon::Copy %W} 5144 bind TkConsole <$cut> {::tkcon::Cut %W} 5145 bind TkConsole <$paste> {::tkcon::Paste %W} 5146 } 5147 5148 proc ::tkcon::GetSelection {w} { 5149 if { 5150 ![catch {selection get -displayof $w -type UTF8_STRING} txt] || 5151 ![catch {selection get -displayof $w} txt] || 5152 ![catch {selection get -displayof $w -selection CLIPBOARD} txt] 5153 } { 5154 return $txt 5155 } 5156 return -code error "could not find default selection" 5157 } 5158 5159 proc ::tkcon::Cut w { 5160 if {[string match $w [selection own -displayof $w]]} { 5161 clipboard clear -displayof $w 5162 catch { 5163 set txt [selection get -displayof $w] 5164 clipboard append -displayof $w $txt 5165 if {[$w compare sel.first >= limit]} { 5166 $w delete sel.first sel.last 5167 } 5168 } 5169 } 5170 } 5171 proc ::tkcon::Copy w { 5172 if {[string match $w [selection own -displayof $w]]} { 5173 clipboard clear -displayof $w 5174 catch { 5175 set txt [selection get -displayof $w] 5176 clipboard append -displayof $w $txt 5177 } 5178 } 5179 } 5180 proc ::tkcon::Paste w { 5181 if {![catch {GetSelection $w} txt]} { 5182 catch { 5183 if {[$w compare sel.first >= limit]} { 5184 $w delete sel.first sel.last 5185 } 5186 } 5187 if {[$w compare insert < limit]} { $w mark set insert end } 5188 $w insert insert $txt 5189 $w see insert 5190 if {[string match *\n* $txt]} { ::tkcon::Eval $w } 5191 } 5192 } 5193 5194 ## Redefine for TkConsole what we need 5195 ## 5196 event delete <<Paste>> <Control-V> 5197 ::tkcon::ClipboardKeysyms <Copy> <Cut> <Paste> 5198 5199 bind TkConsole <Insert> { 5200 catch { ::tkcon::Insert %W [::tkcon::GetSelection %W] } 5201 } 5202 5203 bind TkConsole <Triple-1> {+ 5204 catch { 5205 eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] 5206 eval %W tag remove sel sel.last-1c 5207 %W mark set insert sel.first 5208 } 5209 } 5210 5211 ## binding editor needed 5212 ## binding <events> for .tkconrc 5213 5214 bind TkConsole <<TkCon_ExpandFile>> { 5215 if {[%W compare insert > limit]} {::tkcon::Expand %W path} 5216 break ; # could check "%K" == "Tab" 5217 } 5218 bind TkConsole <<TkCon_ExpandProc>> { 5219 if {[%W compare insert > limit]} {::tkcon::Expand %W proc} 5220 break ; # could check "%K" == "Tab" 5221 } 5222 bind TkConsole <<TkCon_ExpandVar>> { 5223 if {[%W compare insert > limit]} {::tkcon::Expand %W var} 5224 break ; # could check "%K" == "Tab" 5225 } 5226 bind TkConsole <<TkCon_Expand>> { 5227 if {[%W compare insert > limit]} {::tkcon::Expand %W} 5228 break ; # could check "%K" == "Tab" 5229 } 5230 bind TkConsole <<TkCon_Tab>> { 5231 if {[%W compare insert >= limit]} { 5232 ::tkcon::Insert %W \t 5233 } 5234 } 5235 bind TkConsole <<TkCon_Newline>> { 5236 if {[%W compare insert >= limit]} { 5237 ::tkcon::Insert %W \n 5238 } 5239 } 5240 bind TkConsole <<TkCon_Eval>> { 5241 ::tkcon::Eval %W 5242 } 5243 bind TkConsole <Delete> { 5244 if {[llength [%W tag nextrange sel 1.0 end]] \ 5245 && [%W compare sel.first >= limit]} { 5246 %W delete sel.first sel.last 5247 } elseif {[%W compare insert >= limit]} { 5248 %W delete insert 5249 %W see insert 5250 } 5251 } 5252 bind TkConsole <BackSpace> { 5253 if {[llength [%W tag nextrange sel 1.0 end]] \ 5254 && [%W compare sel.first >= limit]} { 5255 %W delete sel.first sel.last 5256 } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { 5257 %W delete insert-1c 5258 %W see insert 5259 } 5260 } 5261 bind TkConsole <Control-h> [bind TkConsole <BackSpace>] 5262 5263 bind TkConsole <KeyPress> { 5264 ::tkcon::Insert %W %A 5265 } 5266 5267 bind TkConsole <Control-a> { 5268 if {[%W compare {limit linestart} == {insert linestart}]} { 5269 tk::TextSetCursor %W limit 5270 } else { 5271 tk::TextSetCursor %W {insert linestart} 5272 } 5273 } 5274 bind TkConsole <Key-Home> [bind TkConsole <Control-a>] 5275 bind TkConsole <Control-d> { 5276 if {[%W compare insert < limit]} break 5277 %W delete insert 5278 } 5279 bind TkConsole <Control-k> { 5280 if {[%W compare insert < limit]} break 5281 if {[%W compare insert == {insert lineend}]} { 5282 %W delete insert 5283 } else { 5284 %W delete insert {insert lineend} 5285 } 5286 } 5287 bind TkConsole <<TkCon_Clear>> { 5288 ## Clear console buffer, without losing current command line input 5289 set ::tkcon::PRIV(tmp) [::tkcon::CmdGet %W] 5290 clear 5291 ::tkcon::Prompt {} $::tkcon::PRIV(tmp) 5292 } 5293 bind TkConsole <<TkCon_Previous>> { 5294 if {[%W compare {insert linestart} != {limit linestart}]} { 5295 tk::TextSetCursor %W [tk::TextUpDownLine %W -1] 5296 } else { 5297 ::tkcon::Event -1 5298 } 5299 } 5300 bind TkConsole <<TkCon_Next>> { 5301 if {[%W compare {insert linestart} != {end-1c linestart}]} { 5302 tk::TextSetCursor %W [tk::TextUpDownLine %W 1] 5303 } else { 5304 ::tkcon::Event 1 5305 } 5306 } 5307 bind TkConsole <<TkCon_NextImmediate>> { ::tkcon::Event 1 } 5308 bind TkConsole <<TkCon_PreviousImmediate>> { ::tkcon::Event -1 } 5309 bind TkConsole <<TkCon_PreviousSearch>> { 5310 ::tkcon::Event -1 [::tkcon::CmdGet %W] 5311 } 5312 bind TkConsole <<TkCon_NextSearch>> { 5313 ::tkcon::Event 1 [::tkcon::CmdGet %W] 5314 } 5315 bind TkConsole <<TkCon_Transpose>> { 5316 ## Transpose current and previous chars 5317 if {[%W compare insert > "limit+1c"]} { tk::TextTranspose %W } 5318 } 5319 bind TkConsole <<TkCon_ClearLine>> { 5320 ## Clear command line (Unix shell staple) 5321 %W delete limit end 5322 } 5323 bind TkConsole <<TkCon_SaveCommand>> { 5324 ## Save command buffer (swaps with current command) 5325 set ::tkcon::PRIV(tmp) $::tkcon::PRIV(cmdsave) 5326 set ::tkcon::PRIV(cmdsave) [::tkcon::CmdGet %W] 5327 if {[string match {} $::tkcon::PRIV(cmdsave)]} { 5328 set ::tkcon::PRIV(cmdsave) $::tkcon::PRIV(tmp) 5329 } else { 5330 %W delete limit end-1c 5331 } 5332 ::tkcon::Insert %W $::tkcon::PRIV(tmp) 5333 %W see end 5334 } 5335 catch {bind TkConsole <Key-Page_Up> { tk::TextScrollPages %W -1 }} 5336 catch {bind TkConsole <Key-Prior> { tk::TextScrollPages %W -1 }} 5337 catch {bind TkConsole <Key-Page_Down> { tk::TextScrollPages %W 1 }} 5338 catch {bind TkConsole <Key-Next> { tk::TextScrollPages %W 1 }} 5339 bind TkConsole <$PRIV(meta)-d> { 5340 if {[%W compare insert >= limit]} { 5341 %W delete insert {insert wordend} 5342 } 5343 } 5344 bind TkConsole <$PRIV(meta)-BackSpace> { 5345 if {[%W compare {insert -1c wordstart} >= limit]} { 5346 %W delete {insert -1c wordstart} insert 5347 } 5348 } 5349 bind TkConsole <$PRIV(meta)-Delete> { 5350 if {[%W compare insert >= limit]} { 5351 %W delete insert {insert wordend} 5352 } 5353 } 5354 bind TkConsole <ButtonRelease-2> { 5355 if { 5356 (!$tk::Priv(mouseMoved) || $tk_strictMotif) && 5357 ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)] 5358 } { 5359 if {[%W compare @%x,%y < limit]} { 5360 %W insert end $::tkcon::PRIV(tmp) 5361 } else { 5362 %W insert @%x,%y $::tkcon::PRIV(tmp) 5363 } 5364 if {[string match *\n* $::tkcon::PRIV(tmp)]} {::tkcon::Eval %W} 5365 } 5366 } 5367 5368 ## 5369 ## End TkConsole bindings 5370 ## 5371 5372 ## 5373 ## Bindings for doing special things based on certain keys 5374 ## 5375 bind TkConsolePost <Key-parenright> { 5376 if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ 5377 [string compare \\ [%W get insert-2c]]} { 5378 ::tkcon::MatchPair %W \( \) limit 5379 } 5380 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5381 } 5382 bind TkConsolePost <Key-bracketright> { 5383 if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ 5384 [string compare \\ [%W get insert-2c]]} { 5385 ::tkcon::MatchPair %W \[ \] limit 5386 } 5387 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5388 } 5389 bind TkConsolePost <Key-braceright> { 5390 if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ 5391 [string compare \\ [%W get insert-2c]]} { 5392 ::tkcon::MatchPair %W \{ \} limit 5393 } 5394 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5395 } 5396 bind TkConsolePost <Key-quotedbl> { 5397 if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ 5398 [string compare \\ [%W get insert-2c]]} { 5399 ::tkcon::MatchQuote %W limit 5400 } 5401 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5402 } 5403 5404 bind TkConsolePost <KeyPress> { 5405 if {[winfo exists "%W"]} { 5406 if {$::tkcon::OPT(lightcmd) && [string compare {} %A]} { 5407 ::tkcon::TagProc %W 5408 } 5409 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5410 } 5411 } 5412 5413 bind TkConsolePost <Button-1> { 5414 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5415 } 5416 bind TkConsolePost <B1-Motion> { 5417 set ::tkcon::PRIV(StatusCursor) [%W index insert] 5418 } 5419 5420} 5421 5422## 5423# ::tkcon::PopupMenu - what to do when the popup menu is requested 5424## 5425proc ::tkcon::PopupMenu {X Y} { 5426 variable PRIV 5427 variable OPT 5428 5429 set w $PRIV(console) 5430 if {[string compare $w [winfo containing $X $Y]]} { 5431 tk_popup $PRIV(popup) $X $Y 5432 return 5433 } 5434 set x [expr {$X-[winfo rootx $w]}] 5435 set y [expr {$Y-[winfo rooty $w]}] 5436 if {[llength [set tags [$w tag names @$x,$y]]]} { 5437 if {[lsearch -exact $tags "proc"] >= 0} { 5438 lappend type "proc" 5439 foreach {first last} [$w tag prevrange proc @$x,$y] { 5440 set word [$w get $first $last]; break 5441 } 5442 } 5443 if {[lsearch -exact $tags "var"] >= 0} { 5444 lappend type "var" 5445 foreach {first last} [$w tag prevrange var @$x,$y] { 5446 set word [$w get $first $last]; break 5447 } 5448 } 5449 } 5450 if {![info exists type]} { 5451 set exp "(^|\[^\\\\\]\[ \t\n\r\])" 5452 set exp2 "\[\[\\\\\\?\\*\]" 5453 set i [$w search -backwards -regexp $exp @$x,$y "@$x,$y linestart"] 5454 if {[string compare {} $i]} { 5455 if {![string match *.0 $i]} {append i +2c} 5456 if {[string compare {} \ 5457 [set j [$w search -regexp $exp $i "$i lineend"]]]} { 5458 append j +1c 5459 } else { 5460 set j "$i lineend" 5461 } 5462 regsub -all $exp2 [$w get $i $j] {\\\0} word 5463 set word [string trim $word {\"$[]{}',?#*}] 5464 if {[llength [EvalAttached [list info commands $word]]]} { 5465 lappend type "proc" 5466 } 5467 if {[llength [EvalAttached [list info vars $word]]]} { 5468 lappend type "var" 5469 } 5470 if {[EvalAttached [list file isfile $word]]} { 5471 lappend type "file" 5472 } 5473 } 5474 } 5475 if {![info exists type] || ![info exists word]} { 5476 tk_popup $PRIV(popup) $X $Y 5477 return 5478 } 5479 $PRIV(context) delete 0 end 5480 $PRIV(context) add command -label "$word" -state disabled 5481 $PRIV(context) add separator 5482 set app [Attach] 5483 if {[lsearch $type proc] != -1} { 5484 $PRIV(context) add command -label "View Procedure" \ 5485 -command [list $OPT(edit) -attach $app -type proc -- $word] 5486 } 5487 if {[lsearch $type var] != -1} { 5488 $PRIV(context) add command -label "View Variable" \ 5489 -command [list $OPT(edit) -attach $app -type var -- $word] 5490 } 5491 if {[lsearch $type file] != -1} { 5492 $PRIV(context) add command -label "View File" \ 5493 -command [list $OPT(edit) -attach $app -type file -- $word] 5494 } 5495 tk_popup $PRIV(context) $X $Y 5496} 5497 5498## ::tkcon::TagProc - tags a procedure in the console if it's recognized 5499## This procedure is not perfect. However, making it perfect wastes 5500## too much CPU time... 5501## 5502proc ::tkcon::TagProc w { 5503 set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" 5504 set i [$w search -backwards -regexp $exp insert-1c limit-1c] 5505 if {[string compare {} $i]} {append i +2c} else {set i limit} 5506 regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c 5507 if {[llength [EvalAttached [list info commands $c]]]} { 5508 $w tag add proc $i "insert-1c wordend" 5509 } else { 5510 $w tag remove proc $i "insert-1c wordend" 5511 } 5512 if {[llength [EvalAttached [list info vars $c]]]} { 5513 $w tag add var $i "insert-1c wordend" 5514 } else { 5515 $w tag remove var $i "insert-1c wordend" 5516 } 5517} 5518 5519## ::tkcon::MatchPair - blinks a matching pair of characters 5520## c2 is assumed to be at the text index 'insert'. 5521## This proc is really loopy and took me an hour to figure out given 5522## all possible combinations with escaping except for escaped \'s. 5523## It doesn't take into account possible commenting... Oh well. If 5524## anyone has something better, I'd like to see/use it. This is really 5525## only efficient for small contexts. 5526# ARGS: w - console text widget 5527# c1 - first char of pair 5528# c2 - second char of pair 5529# Calls: ::tkcon::Blink 5530## 5531proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} { 5532 if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { 5533 while { 5534 [string match {\\} [$w get $ix-1c]] && 5535 [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] 5536 } {} 5537 set i1 insert-1c 5538 while {[string compare {} $ix]} { 5539 set i0 $ix 5540 set j 0 5541 while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { 5542 append i0 +1c 5543 if {[string match {\\} [$w get $i0-2c]]} continue 5544 incr j 5545 } 5546 if {!$j} break 5547 set i1 $ix 5548 while {$j && [string compare {} \ 5549 [set ix [$w search -back $c1 $ix $lim]]]} { 5550 if {[string match {\\} [$w get $ix-1c]]} continue 5551 incr j -1 5552 } 5553 } 5554 if {[string match {} $ix]} { set ix [$w index $lim] } 5555 } else { set ix [$w index $lim] } 5556 if {$::tkcon::OPT(blinkrange)} { 5557 Blink $w $ix [$w index insert] 5558 } else { 5559 Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] 5560 } 5561} 5562 5563## ::tkcon::MatchQuote - blinks between matching quotes. 5564## Blinks just the quote if it's unmatched, otherwise blinks quoted string 5565## The quote to match is assumed to be at the text index 'insert'. 5566# ARGS: w - console text widget 5567# Calls: ::tkcon::Blink 5568## 5569proc ::tkcon::MatchQuote {w {lim 1.0}} { 5570 set i insert-1c 5571 set j 0 5572 while {[string compare [set i [$w search -back \" $i $lim]] {}]} { 5573 if {[string match {\\} [$w get $i-1c]]} continue 5574 if {!$j} {set i0 $i} 5575 incr j 5576 } 5577 if {$j&1} { 5578 if {$::tkcon::OPT(blinkrange)} { 5579 Blink $w $i0 [$w index insert] 5580 } else { 5581 Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] 5582 } 5583 } else { 5584 Blink $w [$w index insert-1c] [$w index insert] 5585 } 5586} 5587 5588## ::tkcon::Blink - blinks between n index pairs for a specified duration. 5589# ARGS: w - console text widget 5590# i1 - start index to blink region 5591# i2 - end index of blink region 5592# dur - duration in usecs to blink for 5593# Outputs: blinks selected characters in $w 5594## 5595proc ::tkcon::Blink {w args} { 5596 eval [list $w tag add blink] $args 5597 after $::tkcon::OPT(blinktime) [list $w] tag remove blink $args 5598 return 5599} 5600 5601 5602## ::tkcon::Insert 5603## Insert a string into a text console at the point of the insertion cursor. 5604## If there is a selection in the text, and it covers the point of the 5605## insertion cursor, then delete the selection before inserting. 5606# ARGS: w - text window in which to insert the string 5607# s - string to insert (usually just a single char) 5608# Outputs: $s to text widget 5609## 5610proc ::tkcon::Insert {w s} { 5611 if {[string match {} $s] || [string match disabled [$w cget -state]]} { 5612 return 5613 } 5614 variable EXP 5615 if {[info exists EXP(spawn_id)]} { 5616 exp_send -i $EXP(spawn_id) -- $s 5617 return 5618 } 5619 if {[$w comp insert < limit]} { 5620 $w mark set insert end 5621 } 5622 if {[llength [$w tag ranges sel]] && \ 5623 [$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { 5624 $w delete sel.first sel.last 5625 } 5626 $w insert insert $s 5627 $w see insert 5628} 5629 5630## ::tkcon::Expand - 5631# ARGS: w - text widget in which to expand str 5632# type - type of expansion (path / proc / variable) 5633# Calls: ::tkcon::Expand(Pathname|Procname|Variable) 5634# Outputs: The string to match is expanded to the longest possible match. 5635# If ::tkcon::OPT(showmultiple) is non-zero and the user longest 5636# match equaled the string to expand, then all possible matches 5637# are output to stdout. Triggers bell if no matches are found. 5638# Returns: number of matches found 5639## 5640proc ::tkcon::Expand {w {type ""}} { 5641 set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]" 5642 set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] 5643 if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit} 5644 if {[$w compare $tmp >= insert]} return 5645 set str [$w get $tmp insert] 5646 switch -glob $type { 5647 pa* { set res [ExpandPathname $str] } 5648 pr* { set res [ExpandProcname $str] } 5649 v* { set res [ExpandVariable $str] } 5650 default { 5651 set res {} 5652 foreach t $::tkcon::OPT(expandorder) { 5653 if {![catch {Expand$t $str} res] && \ 5654 [string compare {} $res]} break 5655 } 5656 } 5657 } 5658 set len [llength $res] 5659 if {$len} { 5660 $w delete $tmp insert 5661 $w insert $tmp [lindex $res 0] 5662 if {$len > 1} { 5663 if {$::tkcon::OPT(showmultiple) && \ 5664 ![string compare [lindex $res 0] $str]} { 5665 puts stdout [lsort [lreplace $res 0 0]] 5666 } 5667 } 5668 } else { bell } 5669 return [incr len -1] 5670} 5671 5672## ::tkcon::ExpandPathname - expand a file pathname based on $str 5673## This is based on UNIX file name conventions 5674# ARGS: str - partial file pathname to expand 5675# Calls: ::tkcon::ExpandBestMatch 5676# Returns: list containing longest unique match followed by all the 5677# possible further matches 5678## 5679proc ::tkcon::ExpandPathname str { 5680 set pwd [EvalAttached pwd] 5681 # Cause a string like {C:/Program\ Files/} to become "C:/Program Files/" 5682 regsub -all {\\([][ ])} $str {\1} str 5683 if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { 5684 return -code error $err 5685 } 5686 set dir [file tail $str] 5687 ## Check to see if it was known to be a directory and keep the trailing 5688 ## slash if so (file tail cuts it off) 5689 if {[string match */ $str]} { append dir / } 5690 # Create a safely glob-able name 5691 regsub -all {([][])} $dir {\\\1} safedir 5692 if {[catch {lsort [EvalAttached [list glob $safedir*]]} m]} { 5693 set match {} 5694 } else { 5695 if {[llength $m] > 1} { 5696 global tcl_platform 5697 if {[string match windows $tcl_platform(platform)]} { 5698 ## Windows is screwy because it's case insensitive 5699 set tmp [ExpandBestMatch [string tolower $m] \ 5700 [string tolower $dir]] 5701 ## Don't change case if we haven't changed the word 5702 if {[string length $dir]==[string length $tmp]} { 5703 set tmp $dir 5704 } 5705 } else { 5706 set tmp [ExpandBestMatch $m $dir] 5707 } 5708 if {[string match */* $str]} { 5709 set tmp [string trimright [file dirname $str] /]/$tmp 5710 } 5711 regsub -all {([^\\])([][ ])} $tmp {\1\\\2} tmp 5712 set match [linsert $m 0 $tmp] 5713 } else { 5714 ## This may look goofy, but it handles spaces in path names 5715 eval append match $m 5716 if {[file isdirectory $match]} {append match /} 5717 if {[string match */* $str]} { 5718 set match [string trimright [file dirname $str] /]/$match 5719 } 5720 regsub -all {([^\\])([][ ])} $match {\1\\\2} match 5721 ## Why is this one needed and the ones below aren't!! 5722 set match [list $match] 5723 } 5724 } 5725 EvalAttached [list cd $pwd] 5726 return $match 5727} 5728 5729## ::tkcon::ExpandProcname - expand a tcl proc name based on $str 5730# ARGS: str - partial proc name to expand 5731# Calls: ::tkcon::ExpandBestMatch 5732# Returns: list containing longest unique match followed by all the 5733# possible further matches 5734## 5735proc ::tkcon::ExpandProcname str { 5736 set match [EvalAttached [list info commands $str*]] 5737 if {[llength $match] == 0} { 5738 set ns [EvalAttached \ 5739 "namespace children \[namespace current\] [list $str*]"] 5740 if {[llength $ns]==1} { 5741 set match [EvalAttached [list info commands ${ns}::*]] 5742 } else { 5743 set match $ns 5744 } 5745 } 5746 if {[llength $match] > 1} { 5747 regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str 5748 set match [linsert $match 0 $str] 5749 } else { 5750 regsub -all {([^\\]) } $match {\1\\ } match 5751 } 5752 return $match 5753} 5754 5755## ::tkcon::ExpandXotcl - expand an xotcl method name based on $str 5756# ARGS: str - partial proc name to expand 5757# Calls: ::tkcon::ExpandBestMatch 5758# Returns: list containing longest unique match followed by all the 5759# possible further matches 5760## 5761proc ::tkcon::ExpandXotcl str { 5762 # in a first step, get the cmd to check, if we should handle subcommands 5763 set cmd [::tkcon::CmdGet $::tkcon::PRIV(console)] 5764 # Only do the xotcl magic if there are two cmds and xotcl is loaded 5765 if {[llength $cmd] != 2 5766 || ![EvalAttached [list info exists ::xotcl::version]]} { 5767 return 5768 } 5769 set obj [lindex $cmd 0] 5770 set sub [lindex $cmd 1] 5771 set match [EvalAttached [list $obj info methods $sub*]] 5772 if {[llength $match] > 1} { 5773 regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str 5774 set match [linsert $match 0 $str] 5775 } else { 5776 regsub -all {([^\\]) } $match {\1\\ } match 5777 } 5778 return $match 5779} 5780 5781## ::tkcon::ExpandVariable - expand a tcl variable name based on $str 5782# ARGS: str - partial tcl var name to expand 5783# Calls: ::tkcon::ExpandBestMatch 5784# Returns: list containing longest unique match followed by all the 5785# possible further matches 5786## 5787proc ::tkcon::ExpandVariable str { 5788 if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { 5789 ## Looks like they're trying to expand an array. 5790 set match [EvalAttached [list array names $ary $str*]] 5791 if {[llength $match] > 1} { 5792 set vars $ary\([ExpandBestMatch $match $str] 5793 foreach var $match {lappend vars $ary\($var\)} 5794 return $vars 5795 } elseif {[llength $match] == 1} { 5796 set match $ary\($match\) 5797 } 5798 ## Space transformation avoided for array names. 5799 } else { 5800 set match [EvalAttached [list info vars $str*]] 5801 if {[llength $match] > 1} { 5802 regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str 5803 set match [linsert $match 0 $str] 5804 } else { 5805 regsub -all {([^\\]) } $match {\1\\ } match 5806 } 5807 } 5808 return $match 5809} 5810 5811## ::tkcon::ExpandBestMatch2 - finds the best unique match in a list of names 5812## Improves upon the speed of the below proc only when $l is small 5813## or $e is {}. $e is extra for compatibility with proc below. 5814# ARGS: l - list to find best unique match in 5815# Returns: longest unique match in the list 5816## 5817proc ::tkcon::ExpandBestMatch2 {l {e {}}} { 5818 set s [lindex $l 0] 5819 if {[llength $l]>1} { 5820 set i [expr {[string length $s]-1}] 5821 foreach l $l { 5822 while {$i>=0 && [string first $s $l]} { 5823 set s [string range $s 0 [incr i -1]] 5824 } 5825 } 5826 } 5827 return $s 5828} 5829 5830## ::tkcon::ExpandBestMatch - finds the best unique match in a list of names 5831## The extra $e in this argument allows us to limit the innermost loop a 5832## little further. This improves speed as $l becomes large or $e becomes long. 5833# ARGS: l - list to find best unique match in 5834# e - currently best known unique match 5835# Returns: longest unique match in the list 5836## 5837proc ::tkcon::ExpandBestMatch {l {e {}}} { 5838 set ec [lindex $l 0] 5839 if {[llength $l]>1} { 5840 set e [string length $e]; incr e -1 5841 set ei [string length $ec]; incr ei -1 5842 foreach l $l { 5843 while {$ei>=$e && [string first $ec $l]} { 5844 set ec [string range $ec 0 [incr ei -1]] 5845 } 5846 } 5847 } 5848 return $ec 5849} 5850 5851# Here is a group of functions that is only used when Tkcon is 5852# executed in a safe interpreter. It provides safe versions of 5853# missing functions. For example: 5854# 5855# - "tk appname" returns "tkcon.tcl" but cannot be set 5856# - "toplevel" is equivalent to 'frame', only it is automatically 5857# packed. 5858# - The 'source', 'load', 'open', 'file' and 'exit' functions are 5859# mapped to corresponding functions in the parent interpreter. 5860# 5861# Further on, Tk cannot be really loaded. Still the safe 'load' 5862# provedes a speciall case. The Tk can be divided into 4 groups, 5863# that each has a safe handling procedure. 5864# 5865# - "::tkcon::SafeItem" handles commands like 'button', 'canvas' ...... 5866# Each of these functions has the window name as first argument. 5867# - "::tkcon::SafeManage" handles commands like 'pack', 'place', 'grid', 5868# 'winfo', which can have multiple window names as arguments. 5869# - "::tkcon::SafeWindow" handles all windows, such as '.'. For every 5870# window created, a new alias is formed which also is handled by 5871# this function. 5872# - Other (e.g. bind, bindtag, image), which need their own function. 5873# 5874## These functions courtesy Jan Nijtmans 5875## 5876if {![llength [info commands tk]]} { 5877 proc tk {option args} { 5878 if {![string match app* $option]} { 5879 error "wrong option \"$option\": should be appname" 5880 } 5881 return "tkcon.tcl" 5882 } 5883} 5884 5885if {![llength [info command toplevel]]} { 5886 proc toplevel {name args} { 5887 eval [linsert $args 0 frame $name] 5888 grid $name -sticky news 5889 } 5890} 5891 5892proc ::tkcon::SafeSource {i f} { 5893 set fd [open $f r] 5894 set r [read $fd] 5895 close $fd 5896 if {[catch {interp eval $i $r} msg]} { 5897 error $msg 5898 } 5899} 5900 5901proc ::tkcon::SafeOpen {i f {m r}} { 5902 set fd [open $f $m] 5903 interp transfer {} $fd $i 5904 return $fd 5905} 5906 5907proc ::tkcon::SafeLoad {i f p} { 5908 global tk_version tk_patchLevel tk_library auto_path 5909 if {[string compare $p Tk]} { 5910 load $f $p $i 5911 } else { 5912 foreach command {button canvas checkbutton entry frame label 5913 listbox message radiobutton scale scrollbar spinbox text toplevel} { 5914 $i alias $command ::tkcon::SafeItem $i $command 5915 } 5916 $i alias image ::tkcon::SafeImage $i 5917 foreach command {pack place grid destroy winfo} { 5918 $i alias $command ::tkcon::SafeManage $i $command 5919 } 5920 if {[llength [info command event]]} { 5921 $i alias event ::tkcon::SafeManage $i $command 5922 } 5923 frame .${i}_dot -width 300 -height 300 -relief raised 5924 pack .${i}_dot -side left 5925 $i alias tk tk 5926 $i alias bind ::tkcon::SafeBind $i 5927 $i alias bindtags ::tkcon::SafeBindtags $i 5928 $i alias . ::tkcon::SafeWindow $i {} 5929 foreach var {tk_version tk_patchLevel tk_library auto_path} { 5930 $i eval [list set $var [set $var]] 5931 } 5932 $i eval { 5933 package provide Tk $tk_version 5934 if {[lsearch -exact $auto_path $tk_library] < 0} { 5935 lappend auto_path $tk_library 5936 } 5937 } 5938 return "" 5939 } 5940} 5941 5942proc ::tkcon::SafeSubst {i a} { 5943 set arg1 "" 5944 foreach {arg value} $a { 5945 if {![string compare $arg -textvariable] || 5946 ![string compare $arg -variable]} { 5947 set newvalue "[list $i] $value" 5948 global $newvalue 5949 if {[interp eval $i info exists $value]} { 5950 set $newvalue [interp eval $i set $value] 5951 } else { 5952 catch {unset $newvalue} 5953 } 5954 $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} 5955 set value $newvalue 5956 } elseif {![string compare $arg -command]} { 5957 set value [list $i eval $value] 5958 } 5959 lappend arg1 $arg $value 5960 } 5961 return $arg1 5962} 5963 5964proc ::tkcon::SafeItem {i command w args} { 5965 set args [::tkcon::SafeSubst $i $args] 5966 set code [catch "$command [list .${i}_dot$w] $args" msg] 5967 $i alias $w ::tkcon::SafeWindow $i $w 5968 regsub -all .${i}_dot $msg {} msg 5969 return -code $code $msg 5970} 5971 5972proc ::tkcon::SafeManage {i command args} { 5973 set args1 "" 5974 foreach arg $args { 5975 if {[string match . $arg]} { 5976 set arg .${i}_dot 5977 } elseif {[string match .* $arg]} { 5978 set arg ".${i}_dot$arg" 5979 } 5980 lappend args1 $arg 5981 } 5982 set code [catch "$command $args1" msg] 5983 regsub -all .${i}_dot $msg {} msg 5984 return -code $code $msg 5985} 5986 5987# 5988# FIX: this function doesn't work yet if the binding starts with '+'. 5989# 5990proc ::tkcon::SafeBind {i w args} { 5991 if {[string match . $w]} { 5992 set w .${i}_dot 5993 } elseif {[string match .* $w]} { 5994 set w ".${i}_dot$w" 5995 } 5996 if {[llength $args] > 1} { 5997 set args [list [lindex $args 0] \ 5998 "[list $i] eval [list [lindex $args 1]]"] 5999 } 6000 set code [catch "bind $w $args" msg] 6001 if {[llength $args] <2 && $code == 0} { 6002 set msg [lindex $msg 3] 6003 } 6004 return -code $code $msg 6005} 6006 6007proc ::tkcon::SafeImage {i option args} { 6008 set code [catch "image $option $args" msg] 6009 if {[string match cr* $option]} { 6010 $i alias $msg $msg 6011 } 6012 return -code $code $msg 6013} 6014 6015proc ::tkcon::SafeBindtags {i w {tags {}}} { 6016 if {[string match . $w]} { 6017 set w .${i}_dot 6018 } elseif {[string match .* $w]} { 6019 set w ".${i}_dot$w" 6020 } 6021 set newtags {} 6022 foreach tag $tags { 6023 if {[string match . $tag]} { 6024 lappend newtags .${i}_dot 6025 } elseif {[string match .* $tag]} { 6026 lappend newtags ".${i}_dot$tag" 6027 } else { 6028 lappend newtags $tag 6029 } 6030 } 6031 if {[string match $tags {}]} { 6032 set code [catch {bindtags $w} msg] 6033 regsub -all \\.${i}_dot $msg {} msg 6034 } else { 6035 set code [catch {bindtags $w $newtags} msg] 6036 } 6037 return -code $code $msg 6038} 6039 6040proc ::tkcon::SafeWindow {i w option args} { 6041 if {[string match conf* $option] && [llength $args] > 1} { 6042 set args [::tkcon::SafeSubst $i $args] 6043 } elseif {[string match itemco* $option] && [llength $args] > 2} { 6044 set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]" 6045 } elseif {[string match cr* $option]} { 6046 if {[llength $args]%2} { 6047 set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]" 6048 } else { 6049 set args [::tkcon::SafeSubst $i $args] 6050 } 6051 } elseif {[string match bi* $option] && [llength $args] > 2} { 6052 set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] 6053 } 6054 set code [catch ".${i}_dot$w $option $args" msg] 6055 if {$code} { 6056 regsub -all .${i}_dot $msg {} msg 6057 } elseif {[string match conf* $option] || [string match itemco* $option]} { 6058 if {[llength $args] == 1} { 6059 switch -- $args { 6060 -textvariable - -variable { 6061 set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" 6062 } 6063 -command - updatecommand { 6064 set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" 6065 } 6066 } 6067 } elseif {[llength $args] == 0} { 6068 set args1 "" 6069 foreach el $msg { 6070 switch -- [lindex $el 0] { 6071 -textvariable - -variable { 6072 set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" 6073 } 6074 -command - updatecommand { 6075 set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" 6076 } 6077 } 6078 lappend args1 $el 6079 } 6080 set msg $args1 6081 } 6082 } elseif {[string match cg* $option] || [string match itemcg* $option]} { 6083 switch -- $args { 6084 -textvariable - -variable { 6085 set msg [lrange $msg 1 end] 6086 } 6087 -command - updatecommand { 6088 set msg [lindex $msg 2] 6089 } 6090 } 6091 } elseif {[string match bi* $option]} { 6092 if {[llength $args] == 2 && $code == 0} { 6093 set msg [lindex $msg 2] 6094 } 6095 } 6096 return -code $code $msg 6097} 6098 6099proc ::tkcon::RetrieveFilter {host} { 6100 variable PRIV 6101 set result {} 6102 if {[info exists PRIV(proxy)]} { 6103 if {![regexp "^(localhost|127\.0\.0\.1)" $host]} { 6104 set result [lrange [split [lindex $PRIV(proxy) 0] :] 0 1] 6105 } 6106 } 6107 return $result 6108} 6109 6110proc ::tkcon::RetrieveAuthentication {} { 6111 package require Tk 6112 if {[catch {package require base64}]} { 6113 if {[catch {package require Trf}]} { 6114 error "base64 support not available" 6115 } else { 6116 set local64 "base64 -mode enc" 6117 } 6118 } else { 6119 set local64 "base64::encode" 6120 } 6121 6122 set dlg [toplevel .auth] 6123 catch {wm attributes $dlg -type dialog} 6124 wm title $dlg "Authenticating Proxy Configuration" 6125 set f1 [frame ${dlg}.f1] 6126 set f2 [frame ${dlg}.f2] 6127 button $f2.b -text "OK" -command "destroy $dlg" 6128 pack $f2.b -side right 6129 label $f1.l2 -text "Username" 6130 label $f1.l3 -text "Password" 6131 entry $f1.e2 -textvariable "[namespace current]::conf_userid" 6132 entry $f1.e3 -textvariable "[namespace current]::conf_passwd" -show * 6133 grid $f1.l2 -column 0 -row 0 -sticky e 6134 grid $f1.l3 -column 0 -row 1 -sticky e 6135 grid $f1.e2 -column 1 -row 0 -sticky news 6136 grid $f1.e3 -column 1 -row 1 -sticky news 6137 grid columnconfigure $f1 1 -weight 1 6138 pack $f2 -side bottom -fill x 6139 pack $f1 -side top -anchor n -fill both -expand 1 6140 tkwait window $dlg 6141 set result {} 6142 if {[info exists [namespace current]::conf_userid]} { 6143 set data [subst $[namespace current]::conf_userid] 6144 append data : [subst $[namespace current]::conf_passwd] 6145 set data [$local64 $data] 6146 set result [list "Proxy-Authorization" "Basic $data"] 6147 } 6148 unset [namespace current]::conf_passwd 6149 return $result 6150} 6151 6152proc ::tkcon::Retrieve {} { 6153 # A little bit'o'magic to grab the latest tkcon from CVS and 6154 # save it locally. It doesn't support proxies though... 6155 variable PRIV 6156 6157 set defExt "" 6158 if {[string match "windows" $::tcl_platform(platform)]} { 6159 set defExt ".tcl" 6160 } 6161 set file [tk_getSaveFile -title "Save Latest tkcon to ..." \ 6162 -defaultextension $defExt \ 6163 -initialdir [file dirname $PRIV(SCRIPT)] \ 6164 -initialfile [file tail $PRIV(SCRIPT)] \ 6165 -parent $PRIV(root) \ 6166 -filetypes {{"Tcl Files" {.tcl .tk}} {"All Files" {*.*}}}] 6167 if {[string compare $file ""]} { 6168 package require http 2 6169 set headers {} 6170 if {[info exists PRIV(proxy)]} { 6171 ::http::config -proxyfilter [namespace origin RetrieveFilter] 6172 if {[lindex $PRIV(proxy) 1] != {}} { 6173 set headers [RetrieveAuthentication] 6174 } 6175 } 6176 set token [::http::geturl $PRIV(HEADURL) \ 6177 -headers $headers -timeout 30000] 6178 ::http::wait $token 6179 set code [catch { 6180 set ncode [::http::ncode $token] 6181 set i 0 6182 while {(($ncode >= 301) && ($ncode <= 307)) && [incr i] < 5} { 6183 # redirect to meta Location 6184 array set meta [::http::meta $token] 6185 ::http::cleanup $token 6186 if {![info exists meta(Location)]} { break } 6187 set url $meta(Location) 6188 if {![string match "http*" $url] 6189 && [regexp {https?://[^/]+} $PRIV(HEADURL) srvr]} { 6190 # attach the same http server info 6191 set url $srvr/$url 6192 } 6193 set token [::http::geturl $url -headers $headers -timeout 30000] 6194 ::http::wait $token 6195 set ncode [::http::ncode $token] 6196 } 6197 if {$ncode != 200} { 6198 return "expected http return code 200, received $ncode" 6199 } 6200 set status [::http::status $token] 6201 if {$status == "ok"} { 6202 set data [::http::data $token] 6203 regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion 6204 regexp {VERSION\s+"(\d+\.\d+[^\"]*)"} $data -> tkconVersion 6205 if {(![info exists rcsVersion] || ![info exists tkconVersion]) 6206 && [tk_messageBox -type yesno -icon warning \ 6207 -parent $PRIV(root) \ 6208 -title "Invalid tkcon source code" \ 6209 -message "Source code retrieved does not appear\ 6210 to be correct.\nContinue with save to \"$file\"?"] \ 6211 == "no"} { 6212 return "invalid tkcon source code retrieved" 6213 } 6214 set fid [open $file w] 6215 # We don't want newline mode to change 6216 fconfigure $fid -translation binary 6217 puts -nonewline $fid $data 6218 close $fid 6219 } else { 6220 return "expected http status ok, received $status" 6221 } 6222 } err] 6223 ::http::cleanup $token 6224 if {$code == 2} { 6225 tk_messageBox -type ok -icon info -parent $PRIV(root) \ 6226 -title "Failed to retrieve source" \ 6227 -message "Failed to retrieve latest tkcon source:\n$err\n$PRIV(HEADURL)" 6228 } elseif {$code} { 6229 return -code error $err 6230 } else { 6231 if {![info exists rcsVersion]} { set rcsVersion "UNKNOWN" } 6232 if {![info exists tkconVersion]} { set tkconVersion "UNKNOWN" } 6233 if {[tk_messageBox -type yesno -icon info -parent $PRIV(root) \ 6234 -title "Retrieved tkcon v$tkconVersion, RCS $rcsVersion" \ 6235 -message "Successfully retrieved tkcon v$tkconVersion,\ 6236 RCS $rcsVersion. Shall I resource (not restart) this\ 6237 version now?"] == "yes"} { 6238 set PRIV(SCRIPT) $file 6239 set PRIV(version) $tkconVersion.$rcsVersion 6240 ::tkcon::Resource 6241 } 6242 } 6243 } 6244} 6245 6246## 'send' package that handles multiple communication variants 6247## 6248# Try using Tk send first, then look for a winsend interp, 6249# then try dde and finally have a go at comm 6250namespace eval ::send {} 6251proc ::send::send {args} { 6252 set winfoInterpCmd [list ::winfo interps] 6253 array set opts [list displayof {} async 0] 6254 while {[string match -* [lindex $args 0]]} { 6255 switch -exact -- [lindex $args 0] { 6256 -displayof { 6257 set opts(displayof) [Pop args 1] 6258 lappend winfoInterpCmd -displayof $opts(displayof) 6259 } 6260 -async { set opts(async) 1 } 6261 -- { Pop args ; break } 6262 default { 6263 return -code error "bad option \"[lindex $args 0]\":\ 6264 should be -displayof, -async or --" 6265 } 6266 } 6267 Pop args 6268 } 6269 set app [Pop args] 6270 6271 if {[llength [info commands ::winfo]] 6272 && [lsearch -exact [eval $winfoInterpCmd] $app] > -1} { 6273 set cmd [list ::send] 6274 if {$opts(async) == 1} {lappend cmd -async} 6275 if {$opts(displayof) != {}} {lappend cmd -displayof $opts(displayof)} 6276 lappend cmd $app 6277 eval $cmd $args 6278 } elseif {[llength [info commands ::winsend]] 6279 && [lsearch -exact [::winsend interps] $app] > -1} { 6280 eval [list ::winsend send $app] $args 6281 } elseif {[llength [info commands ::dde]] 6282 && [lsearch -exact [dde services TclEval {}] \ 6283 [list TclEval $app]] > -1} { 6284 eval [list ::dde eval $app] $args 6285 } elseif {[package provide comm] != {} 6286 && [regexp {^[0-9]+$} [lindex $app 0]]} { 6287 #if {$opts(displayof) != {} && [llength $app] == 1} { 6288 # lappend app $opts(displayof) 6289 #} 6290 eval [list ::comm::comm send $app] $args 6291 } else { 6292 return -code error "bad interp: \"$app\" could not be found" 6293 } 6294} 6295 6296proc ::send::interps {args} { 6297 set winfoInterpCmd [list ::winfo interps] 6298 array set opts [list displayof {}] 6299 while {[string match -* [lindex $args 0]]} { 6300 switch -exact -- [lindex $args 0] { 6301 -displayof { 6302 set opts(displayof) [Pop args 1] 6303 lappend winfoInterpCmd -displayof $opts(displayof) 6304 } 6305 -- { Pop args ; break } 6306 default { 6307 return -code error "bad option \"[lindex $args 0]\":\ 6308 should be -displayof or --" 6309 } 6310 } 6311 Pop args 6312 } 6313 6314 set interps {} 6315 if {[llength [info commands ::winfo]]} { 6316 set interps [concat $interps [eval $winfoInterpCmd]] 6317 } 6318 if {[llength [info commands ::winsend]]} { 6319 set interps [concat $interps [::winsend interps]] 6320 } 6321 if {[llength [info commands ::dde]]} { 6322 set servers {} 6323 foreach server [::dde services TclEval {}] { 6324 lappend servers [lindex $server 1] 6325 } 6326 set interps [concat $interps $servers] 6327 } 6328 if {[package provide comm] != {}} { 6329 set interps [concat $interps [::comm::comm interps]] 6330 } 6331 return $interps 6332} 6333 6334proc ::send::appname {args} { 6335 set appname {} 6336 if {[llength [info commands ::tk]]} { 6337 set appname [eval ::tk appname $args] 6338 } 6339 if {[llength [info commands ::winsend]]} { 6340 set appname [concat $appname [eval ::winsend appname $args]] 6341 } 6342 if {[llength [info commands ::dde]]} { 6343 set appname [concat $appname [eval ::dde servername $args]] 6344 } 6345 # comm? can set port num and local/global interface. 6346 return [lsort -unique $appname] 6347} 6348 6349proc ::send::Pop {varname {nth 0}} { 6350 upvar $varname args 6351 set r [lindex $args $nth] 6352 set args [lreplace $args $nth $nth] 6353 return $r 6354} 6355## 6356## end 'send' package 6357 6358## special case 'tk appname' in Tcl plugin 6359if {$::tkcon::PRIV(WWW)} { 6360 rename tk ::tkcon::_tk 6361 proc tk {cmd args} { 6362 if {$cmd == "appname"} { 6363 return "tkcon/WWW" 6364 } else { 6365 return [uplevel 1 ::tkcon::_tk [list $cmd] $args] 6366 } 6367 } 6368} 6369 6370## ::tkcon::Resource - re'source's this script into current console 6371## Meant primarily for my development of this program. It follows 6372## links until the ultimate source is found. 6373## 6374proc ::tkcon::Resource {} { 6375 uplevel \#0 { 6376 if {[catch {source -rsrc tkcon}]} { source $::tkcon::PRIV(SCRIPT) } 6377 } 6378 Bindings 6379 InitSlave $::tkcon::OPT(exec) 6380} 6381 6382## Initialize only if we haven't yet, and do other stuff that prepares to 6383## run. It only actually inits (and runs) tkcon if it is the main script. 6384## 6385proc ::tkcon::AtSource {} { 6386 variable PRIV 6387 6388 # the info script assumes we always call this while being sourced 6389 set PRIV(SCRIPT) [info script] 6390 if {!$PRIV(WWW) && [string length $PRIV(SCRIPT)]} { 6391 if {[info tclversion] >= 8.4} { 6392 set PRIV(SCRIPT) [file normalize $PRIV(SCRIPT)] 6393 } else { 6394 # we use a catch here because some wrap apps choke on 'file type' 6395 # because TclpLstat wasn't wrappable until 8.4. 6396 catch { 6397 while {[string match link [file type $PRIV(SCRIPT)]]} { 6398 set link [file readlink $PRIV(SCRIPT)] 6399 if {[string match relative [file pathtype $link]]} { 6400 set PRIV(SCRIPT) \ 6401 [file join [file dirname $PRIV(SCRIPT)] $link] 6402 } else { 6403 set PRIV(SCRIPT) $link 6404 } 6405 } 6406 catch {unset link} 6407 if {[string match relative [file pathtype $PRIV(SCRIPT)]]} { 6408 set PRIV(SCRIPT) [file join [pwd] $PRIV(SCRIPT)] 6409 } 6410 } 6411 } 6412 } 6413 # normalize argv0 if it was tkcon to ensure that we'll be able 6414 # to load slaves correctly. 6415 if {[info exists ::argv0] && [info script] == $::argv0} { 6416 set ::argv0 $PRIV(SCRIPT) 6417 } 6418 6419 if {(![info exists PRIV(root)] || ![winfo exists $PRIV(root)]) \ 6420 && ([info exists ::argv0] && $PRIV(SCRIPT) == $::argv0)} { 6421 global argv 6422 if {[info exists argv]} { 6423 eval ::tkcon::Init $argv 6424 } else { 6425 ::tkcon::Init 6426 } 6427 } 6428} 6429tkcon::AtSource 6430 6431package provide tkcon $::tkcon::VERSION 6432