1#!/bin/sh 2# \ 3exec wish4.1 "$0" ${1+"$@"} 4 5# 6## stripped.tcl 7## Stripped down version of Tk Console Widget, part of the VerTcl system 8## Stripped to work with Netscape Tk Plugin. 9## 10## Copyright (c) 1995,1996 by Jeffrey Hobbs 11## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ 12## source standard_disclaimer.tcl 13 14if {[info tclversion] < 7.5} { 15 error "TkCon requires at least the stable version of tcl7.5/tk4.1" 16} 17 18## tkConInit - inits tkCon 19# ARGS: root - widget pathname of the tkCon console root 20# title - title for the console root and main (.) windows 21# Calls: tkConInitUI 22# Outputs: errors found in tkCon resource file 23## 24proc tkConInit {{title Main}} { 25 global tkCon tcl_platform env auto_path tcl_interactive 26 27 set tcl_interactive 1 28 29 array set tkCon { 30 color,blink yellow 31 color,proc darkgreen 32 color,prompt brown 33 color,stdin black 34 color,stdout blue 35 color,stderr red 36 37 blinktime 500 38 font fixed 39 lightbrace 1 40 lightcmd 1 41 prompt1 {[history nextid] % } 42 prompt2 {[history nextid] cont > } 43 showmultiple 1 44 slavescript {} 45 46 cmd {} cmdbuf {} cmdsave {} event 1 svnt 1 cols 80 rows 24 47 48 version {0.5x Stripped} 49 base .console 50 } 51 52 if [string comp $tcl_platform(platform) unix] { 53 array set tkCon { 54 font {Courier 12 {}} 55 } 56 } 57 58 tkConInitUI $title 59 60 interp alias {} clean {} tkConStateRevert tkCon 61 tkConStateCheckpoint tkCon 62} 63 64## tkConInitUI - inits UI portion (console) of tkCon 65## Creates all elements of the console window and sets up the text tags 66# ARGS: title - title for the console root and main (.) windows 67# Calls: tkConInitMenus, tkConPrompt 68## 69proc tkConInitUI {title} { 70 global tkCon 71 72 set root $tkCon(base) 73 if [string match $root .] { set w {} } else { set w [frame $root] } 74 75 set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \ 76 -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)] 77 bindtags $w.text "$w.text PreCon Console PostCon $root all" 78 set tkCon(scrolly) [scrollbar $w.sy \ 79 -command "$w.text yview" -takefocus 0 -bd 1] 80 81 pack $w.sy -side left -fill y 82 set tkCon(scrollypos) left 83 pack $w.text -fill both -expand 1 84 85 $w.text insert insert "$title console display active\n" stdout 86 tkConPrompt $w.text 87 88 foreach col {prompt stdout stderr stdin proc} { 89 $w.text tag configure $col -foreground $tkCon(color,$col) 90 } 91 $w.text tag configure blink -background $tkCon(color,blink) 92 93 pack $root -fill both -expand 1 94 focus $w.text 95} 96 97## tkConEval - evaluates commands input into console window 98## This is the first stage of the evaluating commands in the console. 99## They need to be broken up into consituent commands (by tkConCmdSep) in 100## case a multiple commands were pasted in, then each is eval'ed (by 101## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. 102# ARGS: w - console text widget 103# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd 104## 105proc tkConEval {w} { 106 global tkCon 107 tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) 108 $w mark set insert end-1c 109 $w insert end \n 110 if [llength $cmds] { 111 foreach cmd $cmds {tkConEvalCmd $w $cmd} 112 $w insert insert $tkCon(cmd) {} 113 } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { 114 tkConEvalCmd $w $tkCon(cmd) 115 } 116 $w see insert 117} 118 119## tkConEvalCmd - evaluates a single command, adding it to history 120# ARGS: w - console text widget 121# cmd - the command to evaluate 122# Calls: tkConPrompt 123# Outputs: result of command to stdout (or stderr if error occured) 124# Returns: next event number 125## 126proc tkConEvalCmd {w cmd} { 127 global tkCon 128 $w mark set output end 129 if [catch {uplevel \#0 history add [list $cmd] exec} result] { 130 $w insert output $result\n stderr 131 } elseif [string comp {} $result] { 132 $w insert output $result\n stdout 133 } 134 tkConPrompt $w 135 set tkCon(svnt) [set tkCon(event) [history nextid]] 136} 137 138## tkConCmdGet - gets the current command from the console widget 139# ARGS: w - console text widget 140# Returns: text which compromises current command line 141## 142proc tkConCmdGet w { 143 if [string match {} [set ix [$w tag nextrange prompt limit end]]] { 144 $w tag add stdin limit end-1c 145 return [$w get limit end-1c] 146 } 147} 148 149## tkConCmdSep - separates multiple commands into a list and remainder 150# ARGS: cmd - (possible) multiple command to separate 151# list - varname for the list of commands that were separated. 152# rmd - varname of any remainder (like an incomplete final command). 153# If there is only one command, it's placed in this var. 154# Returns: constituent command info in varnames specified by list & rmd. 155## 156proc tkConCmdSep {cmd ls rmd} { 157 upvar $ls cmds $rmd tmp 158 set tmp {} 159 set cmds {} 160 foreach cmd [split [set cmd] \n] { 161 if [string comp {} $tmp] { 162 append tmp \n$cmd 163 } else { 164 append tmp $cmd 165 } 166 if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { 167 lappend cmds $tmp 168 set tmp {} 169 } 170 } 171 if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { 172 set tmp [lindex $cmds end] 173 set cmds [lreplace $cmds end end] 174 } 175} 176 177## tkConPrompt - displays the prompt in the console widget 178# ARGS: w - console text widget 179# Outputs: prompt (specified in tkCon(prompt1)) to console 180## 181proc tkConPrompt w { 182 global tkCon env 183 set i [$w index end-1c] 184 $w insert end [subst $tkCon(prompt1)] prompt 185 $w mark set output $i 186 $w mark set limit insert 187 $w mark gravity limit left 188} 189 190## tkConStateCheckpoint - checkpoints the current state of the system 191## This allows you to return to this state with tkConStateRevert 192# ARGS: ary an array into which several elements are stored: 193# commands - the currently defined commands 194# variables - the current global vars 195# This is the array you would pass to tkConRevertState 196## 197proc tkConStateCheckpoint {ary} { 198 global tkCon 199 upvar $ary a 200 set a(commands) [uplevel \#0 info commands *] 201 set a(variables) [uplevel \#0 info vars *] 202 return 203} 204 205## tkConStateCompare - compare two states and output difference 206# ARGS: ary1 an array with checkpointed state 207# ary2 a second array with checkpointed state 208# Outputs: 209## 210proc tkConStateCompare {ary1 ary2} { 211 upvar $ary1 a1 $ary2 a2 212 puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]" 213 puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]" 214 puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]" 215 puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]" 216} 217 218## tkConStateRevert - reverts interpreter to a previous state 219# ARGS: ary an array with checkpointed state 220## 221proc tkConStateRevert {ary} { 222 upvar $ary a 223 tkConStateCheckpoint tmp 224 foreach i [lremove $tmp(commands) $a(commands)] { catch "rename $i {}" } 225 foreach i [lremove $tmp(variables) $a(variables)] { uplevel \#0 unset $i } 226} 227 228## 229## Some procedures to make up for lack of built-in shell commands 230## 231 232## puts 233## This allows me to capture all stdout/stderr to the console window 234# ARGS: same as usual 235# Outputs: the string with a color-coded text tag 236## 237catch {rename puts tcl_puts} 238proc puts args { 239 set len [llength $args] 240 if {$len==1} { 241 eval tkcon console insert output $args stdout {\n} stdout 242 tkcon console see output 243 } elseif {$len==2 && 244 [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { 245 if [string comp $tmp -nonewline] { 246 eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp 247 } else { 248 eval tkcon console insert output [lreplace $args 0 0] stdout 249 } 250 tkcon console see output 251 } elseif {$len==3 && 252 [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { 253 if [string comp [lreplace $args 1 2] -nonewline] { 254 eval tkcon console insert output [lrange $args 1 1] $tmp 255 } else { 256 eval tkcon console insert output [lreplace $args 0 1] $tmp 257 } 258 tkcon console see output 259 } else { 260 eval tcl_puts $args 261 } 262} 263 264## alias - akin to the csh alias command 265## If called with no args, then it prints out all current aliases 266## If called with one arg, returns the alias of that arg (or {} if none) 267# ARGS: newcmd - (optional) command to bind alias to 268# args - command and args being aliased 269## 270proc alias {{newcmd {}} args} { 271 if [string match $newcmd {}] { 272 set res {} 273 foreach a [interp aliases] { 274 lappend res [list $a: [interp alias {} $a]] 275 } 276 return [join $res \n] 277 } elseif {[string match {} $args]} { 278 interp alias {} $newcmd 279 } else { 280 eval interp alias {{}} $newcmd {{}} $args 281 } 282} 283 284## unalias - unaliases an alias'ed command 285# ARGS: cmd - command to unbind as an alias 286## 287proc unalias {cmd} { 288 interp alias {} $cmd {} 289} 290 291## tkcon - command that allows control over the console 292# ARGS: totally variable, see internal comments 293## 294proc tkcon {args} { 295 global tkCon 296 switch -- [lindex $args 0] { 297 clean { 298 ## 'cleans' the interpreter - reverting to original tkCon state 299 tkConStateRevert tkCon 300 } 301 console { 302 ## Passes the args to the text widget of the console. 303 eval $tkCon(console) [lreplace $args 0 0] 304 } 305 font { 306 ## "tkcon font ?fontname?". Sets the font of the console 307 if [string comp {} [lindex $args 1]] { 308 return [$tkCon(console) config -font [lindex $args 1]] 309 } else { 310 return [$tkCon(console) config -font] 311 } 312 } 313 version { 314 return $tkCon(version) 315 } 316 default { 317 ## tries to determine if the command exists, otherwise throws error 318 set cmd [lindex $args 0] 319 set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] 320 if [string match $cmd [info command $cmd]] { 321 eval $cmd [lreplace $args 0 0] 322 } else { 323 error "bad option \"[lindex $args 0]\": must be attach,\ 324 clean, console, font" 325 } 326 } 327 } 328} 329 330## clear - clears the buffer of the console (not the history though) 331## This is executed in the parent interpreter 332## 333proc clear {{pcnt 100}} { 334 if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { 335 error "invalid percentage to clear: must be 1-100 (100 default)" 336 } elseif {$pcnt == 100} { 337 tkcon console delete 1.0 end 338 } else { 339 set tmp [expr $pcnt/100.0*[tkcon console index end]] 340 tkcon console delete 1.0 "$tmp linestart" 341 } 342} 343 344## dump - outputs variables/procedure/widget info in source'able form. 345## Accepts glob style pattern matching for the names 346# ARGS: type - type of thing to dump: must be variable, procedure, widget 347# OPTS: -nocomplain don't complain if no vars match something 348# Returns: the values of the variables in a 'source'able form 349## 350proc dump {type args} { 351 set whine 1 352 set code ok 353 if [string match \-n* [lindex $args 0]] { 354 set whine 0 355 set args [lreplace $args 0 0] 356 } 357 if {$whine && [string match {} $args]} { 358 error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?" 359 } 360 set res {} 361 switch -glob -- $type { 362 v* { 363 # variable 364 # outputs variables value(s), whether array or simple. 365 foreach arg $args { 366 if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { 367 if {[uplevel info exists $arg]} { 368 set vars $arg 369 } elseif $whine { 370 append res "\#\# No known variable $arg\n" 371 set code error 372 continue 373 } else continue 374 } 375 foreach var [lsort $vars] { 376 upvar $var v 377 if {[array exists v]} { 378 append res "array set $var \{\n" 379 foreach i [lsort [array names v]] { 380 upvar 0 v\($i\) w 381 if {[array exists w]} { 382 append res " [list $i {NESTED VAR ERROR}]\n" 383 if $whine { set code error } 384 } else { 385 append res " [list $i $v($i)]\n" 386 } 387 } 388 append res "\}\n" 389 } else { 390 append res [list set $var $v]\n 391 } 392 } 393 } 394 } 395 p* { 396 # procedure 397 foreach arg $args { 398 if {[string comp {} [set ps [info proc $arg]]]} { 399 foreach p [lsort $ps] { 400 set as {} 401 foreach a [info args $p] { 402 if {[info default $p $a tmp]} { 403 lappend as [list $a $tmp] 404 } else { 405 lappend as $a 406 } 407 } 408 append res [list proc $p $as [info body $p]]\n 409 } 410 } elseif $whine { 411 append res "\#\# No known proc $arg\n" 412 } 413 } 414 } 415 w* { 416 # widget 417 } 418 default { 419 return -code error "bad [lindex [info level 0] 0] option\ 420 \"[lindex $args 0]\":\ must be procedure, variable, widget" 421 } 422 } 423 return -code $code [string trimr $res \n] 424} 425 426## which - tells you where a command is found 427# ARGS: cmd - command name 428# Returns: where command is found (internal / external / unknown) 429## 430proc which cmd { 431 if [string comp {} [info commands $cmd]] { 432 if {[lsearch -exact [interp aliases] $cmd] > -1} { 433 return "$cmd:\taliased to [alias $cmd]" 434 } elseif [string comp {} [info procs $cmd]] { 435 return "$cmd:\tinternal proc" 436 } else { 437 return "$cmd:\tinternal command" 438 } 439 } else { 440 return "$cmd:\tunknown command" 441 } 442} 443 444## lremove - remove items from a list 445# OPTS: -all remove all instances of each item 446# ARGS: l a list to remove items from 447# is a list of items to remove 448## 449proc lremove {args} { 450 set all 0 451 if [string match \-a* [lindex $args 0]] { 452 set all 1 453 set args [lreplace $args 0 0] 454 } 455 set l [lindex $args 0] 456 eval append is [lreplace $args 0 0] 457 foreach i $is { 458 if {[set ix [lsearch -exact $l $i]] == -1} continue 459 set l [lreplace $l $ix $ix] 460 if $all { 461 while {[set ix [lsearch -exact $l $i]] != -1} { 462 set l [lreplace $l $i $i] 463 } 464 } 465 } 466 return $l 467} 468 469 470## Unknown changed to get output into tkCon window 471## See $tcl_library/init.tcl for an explanation 472## 473proc unknown args { 474 global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon 475 global errorCode errorInfo 476 477 # Save the values of errorCode and errorInfo variables, since they 478 # may get modified if caught errors occur below. The variables will 479 # be restored just before re-executing the missing command. 480 481 set savedErrorCode $errorCode 482 set savedErrorInfo $errorInfo 483 set name [lindex $args 0] 484 if ![info exists auto_noload] { 485 # 486 # Make sure we're not trying to load the same proc twice. 487 # 488 if [info exists unknown_pending($name)] { 489 unset unknown_pending($name) 490 if {[array size unknown_pending] == 0} { 491 unset unknown_pending 492 } 493 return -code error "self-referential recursion in \"unknown\" for command \"$name\""; 494 } 495 set unknown_pending($name) pending; 496 set ret [catch {auto_load $name} msg] 497 unset unknown_pending($name); 498 if {$ret != 0} { 499 return -code $ret -errorcode $errorCode \ 500 "error while autoloading \"$name\": $msg" 501 } 502 if ![array size unknown_pending] { 503 unset unknown_pending 504 } 505 if $msg { 506 set errorCode $savedErrorCode 507 set errorInfo $savedErrorInfo 508 set code [catch {uplevel $args} msg] 509 if {$code == 1} { 510 # 511 # Strip the last five lines off the error stack (they're 512 # from the "uplevel" command). 513 # 514 515 set new [split $errorInfo \n] 516 set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] 517 return -code error -errorcode $errorCode \ 518 -errorinfo $new $msg 519 } else { 520 return -code $code $msg 521 } 522 } 523 } 524 if {[info level] == 1 && [string match {} [info script]] \ 525 && [info exists tcl_interactive] && $tcl_interactive} { 526 if ![info exists auto_noexec] { 527 if [auto_execok $name] { 528 set errorCode $savedErrorCode 529 set errorInfo $savedErrorInfo 530 return [uplevel exec $args] 531 #return [uplevel exec >&@stdout <@stdin $args] 532 } 533 } 534 set errorCode $savedErrorCode 535 set errorInfo $savedErrorInfo 536 if {[string match $name !!]} { 537 catch {set tkCon(cmd) [history event]} 538 return [uplevel {history redo}] 539 } elseif [regexp {^!(.+)$} $name dummy event] { 540 catch {set tkCon(cmd) [history event $event]} 541 return [uplevel [list history redo $event]] 542 } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { 543 catch {set tkCon(cmd) [history substitute $old $new]} 544 return [uplevel [list history substitute $old $new]] 545 } 546 set cmds [info commands $name*] 547 if {[llength $cmds] == 1} { 548 return [uplevel [lreplace $args 0 0 $cmds]] 549 } elseif {[llength $cmds]} { 550 if {$name == ""} { 551 return -code error "empty command name \"\"" 552 } else { 553 return -code error \ 554 "ambiguous command name \"$name\": [lsort $cmds]" 555 } 556 } 557 } 558 return -code error "invalid command name \"$name\"" 559} 560 561 562# tkConClipboardKeysyms -- 563# This procedure is invoked to identify the keys that correspond to 564# the "copy", "cut", and "paste" functions for the clipboard. 565# 566# Arguments: 567# copy - Name of the key (keysym name plus modifiers, if any, 568# such as "Meta-y") used for the copy operation. 569# cut - Name of the key used for the cut operation. 570# paste - Name of the key used for the paste operation. 571 572proc tkConCut w { 573 if [string match $w [selection own -displayof $w]] { 574 clipboard clear -displayof $w 575 catch { 576 clipboard append -displayof $w [selection get -displayof $w] 577 if [$w compare sel.first >= limit] {$w delete sel.first sel.last} 578 } 579 } 580} 581proc tkConCopy w { 582 if [string match $w [selection own -displayof $w]] { 583 clipboard clear -displayof $w 584 catch {clipboard append -displayof $w [selection get -displayof $w]} 585 } 586} 587 588proc tkConPaste w { 589 if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { 590 if [$w compare insert < limit] {$w mark set insert end} 591 $w insert insert $tmp 592 $w see insert 593 if [string match *\n* $tmp] {tkConEval $w} 594 } 595} 596 597proc tkConClipboardKeysyms {copy cut paste} { 598 bind Console <$copy> {tkConCopy %W} 599 bind Console <$cut> {tkConCut %W} 600 bind Console <$paste> {tkConPaste %W} 601} 602 603## Get all Text bindings into Console 604## 605foreach ev [lremove [bind Text] {<Control-Key-y> <Control-Key-w> \ 606 <Meta-Key-w> <Control-Key-o>}] { 607 bind Console $ev [bind Text $ev] 608} 609unset ev 610 611## Redefine for Console what we need 612## 613tkConClipboardKeysyms F16 F20 F18 614tkConClipboardKeysyms Control-c Control-x Control-v 615 616bind Console <Insert> {catch {tkConInsert %W [selection get -displayof %W]}} 617 618bind Console <Up> { 619 if [%W compare {insert linestart} != {limit linestart}] { 620 tkTextSetCursor %W [tkTextUpDownLine %W -1] 621 } else { 622 if {$tkCon(event) == [history nextid]} { 623 set tkCon(cmdbuf) [tkConCmdGet %W] 624 } 625 if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] { 626 incr tkCon(event) 627 } else { 628 %W delete limit end 629 %W insert limit $tkCon(tmp) 630 %W see end 631 } 632 } 633} 634bind Console <Down> { 635 if [%W compare {insert linestart} != {end-1c linestart}] { 636 tkTextSetCursor %W [tkTextUpDownLine %W 1] 637 } else { 638 if {$tkCon(event) < [history nextid]} { 639 %W delete limit end 640 if {[incr tkCon(event)] == [history nextid]} { 641 %W insert limit $tkCon(cmdbuf) 642 } else { 643 %W insert limit [history event $tkCon(event)] 644 } 645 %W see end 646 } 647 } 648} 649bind Console <Control-P> { 650 if [%W compare insert > limit] {tkConExpand %W proc} 651} 652bind Console <Control-V> { 653 if [%W compare insert > limit] {tkConExpand %W var} 654} 655bind Console <Control-i> { 656 if [%W compare insert >= limit] { 657 tkConInsert %W \t 658 } 659} 660bind Console <Return> { 661 tkConEval %W 662} 663bind Console <KP_Enter> [bind Console <Return>] 664bind Console <Delete> { 665 if {[string comp {} [%W tag nextrange sel 1.0 end]] \ 666 && [%W compare sel.first >= limit]} { 667 %W delete sel.first sel.last 668 } elseif [%W compare insert >= limit] { 669 %W delete insert 670 %W see insert 671 } 672} 673bind Console <BackSpace> { 674 if {[string comp {} [%W tag nextrange sel 1.0 end]] \ 675 && [%W compare sel.first >= limit]} { 676 %W delete sel.first sel.last 677 } elseif {[%W compare insert != 1.0] && [%W compare insert-1c >= limit]} { 678 %W delete insert-1c 679 %W see insert 680 } 681} 682bind Console <Control-h> [bind Console <BackSpace>] 683 684bind Console <KeyPress> { 685 tkConInsert %W %A 686} 687 688bind Console <Control-a> { 689 if [%W compare {limit linestart} == {insert linestart}] { 690 tkTextSetCursor %W limit 691 } else { 692 tkTextSetCursor %W {insert linestart} 693 } 694} 695bind Console <Control-d> { 696 if [%W compare insert < limit] break 697 %W delete insert 698} 699bind Console <Control-k> { 700 if [%W compare insert < limit] break 701 if [%W compare insert == {insert lineend}] { 702 %W delete insert 703 } else { 704 %W delete insert {insert lineend} 705 } 706} 707bind Console <Control-l> { 708 ## Clear console buffer, without losing current command line input 709 set tkCon(tmp) [tkConCmdGet %W] 710 clear 711 tkConPrompt 712 tkConInsert %W $tkCon(tmp) 713} 714bind Console <Control-n> { 715 ## Goto next command in history 716 if {$tkCon(event) < [history nextid]} { 717 %W delete limit end 718 if {[incr tkCon(event)] == [history nextid]} { 719 %W insert limit $tkCon(cmdbuf) 720 } else { 721 %W insert limit [history event $tkCon(event)] 722 } 723 %W see end 724 } 725} 726bind Console <Control-p> { 727 ## Goto previous command in history 728 if {$tkCon(event) == [history nextid]} { 729 set tkCon(cmdbuf) [tkConCmdGet %W] 730 } 731 if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] { 732 incr tkCon(event) 733 } else { 734 %W delete limit end 735 %W insert limit $tkCon(tmp) 736 %W see end 737 } 738} 739bind Console <Control-r> { 740 ## Search history reverse 741 if {$tkCon(svnt) == [history nextid]} { 742 set tkCon(cmdbuf) [tkConCmdGet %W] 743 } 744 set tkCon(tmp1) [string len $tkCon(cmdbuf)] 745 incr tkCon(tmp1) -1 746 while 1 { 747 if {[catch {history event [incr tkCon(svnt) -1]} tkCon(tmp)]} { 748 incr tkCon(svnt) 749 break 750 } elseif {![string comp $tkCon(cmdbuf) \ 751 [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { 752 %W delete limit end 753 %W insert limit $tkCon(tmp) 754 break 755 } 756 } 757 %W see end 758} 759bind Console <Control-s> { 760 ## Search history forward 761 set tkCon(tmp1) [string len $tkCon(cmdbuf)] 762 incr tkCon(tmp1) -1 763 while {$tkCon(svnt) < [history nextid]} { 764 if {[incr tkCon(svnt)] == [history nextid]} { 765 %W delete limit end 766 %W insert limit $tkCon(cmdbuf) 767 break 768 } elseif {![catch {history event $tkCon(svnt)} tkCon(tmp)] 769 && ![string comp $tkCon(cmdbuf) \ 770 [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { 771 %W delete limit end 772 %W insert limit $tkCon(tmp) 773 break 774 } 775 } 776 %W see end 777} 778bind Console <Control-t> { 779 ## Transpose current and previous chars 780 if [%W compare insert > limit] { 781 tkTextTranspose %W 782 } 783} 784bind Console <Control-u> { 785 ## Clear command line (Unix shell staple) 786 %W delete limit end 787} 788bind Console <Control-z> { 789 ## Save command buffer 790 set tkCon(tmp) $tkCon(cmdsave) 791 set tkCon(cmdsave) [tkConCmdGet %W] 792 if {[string match {} $tkCon(cmdsave)]} { 793 set tkCon(cmdsave) $tkCon(tmp) 794 } else { 795 %W delete limit end-1c 796 } 797 tkConInsert %W $tkCon(tmp) 798 %W see end 799} 800catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }} 801catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }} 802catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }} 803catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }} 804bind Console <Meta-d> { 805 if [%W compare insert >= limit] { 806 %W delete insert {insert wordend} 807 } 808} 809bind Console <Meta-BackSpace> { 810 if [%W compare {insert -1c wordstart} >= limit] { 811 %W delete {insert -1c wordstart} insert 812 } 813} 814bind Console <Meta-Delete> { 815 if [%W compare insert >= limit] { 816 %W delete insert {insert wordend} 817 } 818} 819bind Console <ButtonRelease-2> { 820 if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \ 821 && ![catch {selection get -displayof %W} tkCon(tmp)]} { 822 if [%W compare @%x,%y < limit] { 823 %W insert end $tkCon(tmp) 824 } else { 825 %W insert @%x,%y $tkCon(tmp) 826 } 827 if [string match *\n* $tkCon(tmp)] {tkConEval %W} 828 } 829} 830 831## 832## End weird bindings 833## 834 835## 836## PostCon bindings, for doing special things based on certain keys 837## 838bind PostCon <Key-parenright> { 839 if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && 840 [string comp \\ [%W get insert-2c]]} { 841 tkConMatchPair %W \( \) 842 } 843} 844bind PostCon <Key-bracketright> { 845 if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && 846 [string comp \\ [%W get insert-2c]]} { 847 tkConMatchPair %W \[ \] 848 } 849} 850bind PostCon <Key-braceright> { 851 if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && 852 [string comp \\ [%W get insert-2c]]} { 853 tkConMatchPair %W \{ \} 854 } 855} 856bind PostCon <Key-quotedbl> { 857 if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && 858 [string comp \\ [%W get insert-2c]]} { 859 tkConMatchQuote %W 860 } 861} 862 863bind PostCon <KeyPress> { 864 if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W } 865} 866 867## tkConTagProc - tags a procedure in the console if it's recognized 868## This procedure is not perfect. However, making it perfect wastes 869## too much CPU time... Also it should check the existence of a command 870## in whatever is the connected slave, not the master interpreter. 871## 872proc tkConTagProc w { 873 set i [$w index "insert-1c wordstart"] 874 set j [$w index "insert-1c wordend"] 875 if {[string comp {} [info command [list [$w get $i $j]]]]} { 876 $w tag add proc $i $j 877 } else { 878 $w tag remove proc $i $j 879 } 880} 881 882 883## tkConMatchPair - blinks a matching pair of characters 884## c2 is assumed to be at the text index 'insert'. 885## This proc is really loopy and took me an hour to figure out given 886## all possible combinations with escaping except for escaped \'s. 887## It doesn't take into account possible commenting... Oh well. If 888## anyone has something better, I'd like to see/use it. This is really 889## only efficient for small contexts. 890# ARGS: w - console text widget 891# c1 - first char of pair 892# c2 - second char of pair 893# Calls: tkConBlink 894## 895proc tkConMatchPair {w c1 c2} { 896 if [string comp {} [set ix [$w search -back $c1 insert limit]]] { 897 while {[string match {\\} [$w get $ix-1c]] && 898 [string comp {} [set ix [$w search -back $c1 $ix-1c limit]]]} {} 899 set i1 insert-1c 900 while {[string comp {} $ix]} { 901 set i0 $ix 902 set j 0 903 while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} { 904 append i0 +1c 905 if {[string match {\\} [$w get $i0-2c]]} continue 906 incr j 907 } 908 if {!$j} break 909 set i1 $ix 910 while {$j && 911 [string comp {} [set ix [$w search -back $c1 $ix limit]]]} { 912 if {[string match {\\} [$w get $ix-1c]]} continue 913 incr j -1 914 } 915 } 916 if [string match {} $ix] { set ix [$w index limit] } 917 } else { set ix [$w index limit] } 918 tkConBlink $w $ix [$w index insert] 919} 920 921## tkConMatchQuote - blinks between matching quotes. 922## Blinks just the quote if it's unmatched, otherwise blinks quoted string 923## The quote to match is assumed to be at the text index 'insert'. 924# ARGS: w - console text widget 925# Calls: tkConBlink 926## 927proc tkConMatchQuote w { 928 set i insert-1c 929 set j 0 930 while {[string comp {} [set i [$w search -back \" $i limit]]]} { 931 if {[string match {\\} [$w get $i-1c]]} continue 932 if {!$j} {set i0 $i} 933 incr j 934 } 935 if [expr $j%2] { 936 tkConBlink $w $i0 [$w index insert] 937 } else { 938 tkConBlink $w [$w index insert-1c] [$w index insert] 939 } 940} 941 942## tkConBlink - blinks between 2 indices for a specified duration. 943# ARGS: w - console text widget 944# i1 - start index to blink region 945# i2 - end index of blink region 946# dur - duration in usecs to blink for 947# Outputs: blinks selected characters in $w 948## 949proc tkConBlink {w i1 i2} { 950 global tkCon 951 $w tag add blink $i1 $i2 952 after $tkCon(blinktime) $w tag remove blink $i1 $i2 953 return 954} 955 956 957## tkConInsert 958## Insert a string into a text at the point of the insertion cursor. 959## If there is a selection in the text, and it covers the point of the 960## insertion cursor, then delete the selection before inserting. 961# ARGS: w - text window in which to insert the string 962# s - string to insert (usually just a single char) 963# Outputs: $s to text widget 964## 965proc tkConInsert {w s} { 966 if {[string match {} $s] || [string match disabled [$w cget -state]]} { 967 return 968 } 969 if [$w comp insert < limit] { 970 $w mark set insert end 971 } 972 catch { 973 if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { 974 $w delete sel.first sel.last 975 } 976 } 977 $w insert insert $s 978 $w see insert 979} 980 981## tkConExpand - 982# ARGS: w - text widget in which to expand str 983# type - type of expansion (path / proc / variable) 984# Calls: tkConExpand(Pathname|Procname|Variable) 985# Outputs: The string to match is expanded to the longest possible match. 986# If tkCon(showmultiple) is non-zero and the user longest match 987# equaled the string to expand, then all possible matches are 988# output to stdout. Triggers bell if no matches are found. 989# Returns: number of matches found 990## 991proc tkConExpand {w type} { 992 set exp "\[^\\]\[ \t\n\r\[\{\"\$]" 993 set tmp [$w search -back -regexp $exp insert-1c limit-1c] 994 if [string compare {} $tmp] {append tmp +2c} else {set tmp limit} 995 if [$w compare $tmp >= insert] return 996 set str [$w get $tmp insert] 997 switch -glob $type { 998 pr* {set res [tkConExpandProcname $str]} 999 v* {set res [tkConExpandVariable $str]} 1000 default {set res {}} 1001 } 1002 set len [llength $res] 1003 if $len { 1004 $w delete $tmp insert 1005 $w insert $tmp [lindex $res 0] 1006 if {$len > 1} { 1007 global tkCon 1008 if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} { 1009 puts stdout [lreplace $res 0 0] 1010 } 1011 } 1012 } 1013 return [incr len -1] 1014} 1015 1016## tkConExpandProcname - expand a tcl proc name based on $str 1017# ARGS: str - partial proc name to expand 1018# Calls: tkConExpandBestMatch 1019# Returns: list containing longest unique match followed by all the 1020# possible further matches 1021## 1022proc tkConExpandProcname str { 1023 set match [info commands $str*] 1024 if {[llength $match] > 1} { 1025 regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str 1026 set match [linsert $match 0 $str] 1027 } else { 1028 regsub -all { } $match {\\ } match 1029 } 1030 return $match 1031} 1032 1033## tkConExpandVariable - expand a tcl variable name based on $str 1034# ARGS: str - partial tcl var name to expand 1035# Calls: tkConExpandBestMatch 1036# Returns: list containing longest unique match followed by all the 1037# possible further matches 1038## 1039proc tkConExpandVariable str { 1040 if [regexp {([^\(]*)\((.*)} $str junk ary str] { 1041 set match [uplevel \#0 array names $ary $str*] 1042 if {[llength $match] > 1} { 1043 set vars $ary\([tkConExpandBestMatch $match $str] 1044 foreach var $match {lappend vars $ary\($var\)} 1045 return $vars 1046 } else {set match $ary\($match\)} 1047 } else { 1048 set match [uplevel \#0 info vars $str*] 1049 if {[llength $match] > 1} { 1050 regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str 1051 set match [linsert $match 0 $str] 1052 } else { 1053 regsub -all { } $match {\\ } match 1054 } 1055 } 1056 return $match 1057} 1058 1059## tkConExpandBestMatch - finds the best unique match in a list of names 1060## The extra $e in this argument allows us to limit the innermost loop a 1061## little further. This improves speed as $l becomes large or $e becomes long. 1062# ARGS: l - list to find best unique match in 1063# e - currently best known unique match 1064# Returns: longest unique match in the list 1065## 1066proc tkConExpandBestMatch {l {e {}}} { 1067 set ec [lindex $l 0] 1068 if {[llength $l]>1} { 1069 set e [string length $e]; incr e -1 1070 set ei [string length $ec]; incr ei -1 1071 foreach l $l { 1072 while {$ei>=$e && [string first $ec $l]} { 1073 set ec [string range $ec 0 [incr ei -1]] 1074 } 1075 } 1076 } 1077 return $ec 1078} 1079 1080 1081## Initialize only if we haven't yet 1082## 1083if [catch {winfo exists $tkCon(base)}] tkConInit 1084