tcl/console.tcl

   1 ##
   2 ## Copyright 1996-1997 Jeffrey Hobbs
   3 ##
   4 ## source standard_disclaimer.tcl
   5 ## source beer_ware.tcl
   6 ##
   7 ## Based off previous work for TkCon
   8 ##
   9
  10 ##------------------------------------------------------------------------
  11 ## PROCEDURE
  12 ##      console
  13 ##
  14 ## DESCRIPTION
  15 ##      Implements a console mega-widget
  16 ##
  17 ## ARGUMENTS
  18 ##      console <window pathname> <options>
  19 ##
  20 ## OPTIONS
  21 ##      (Any frame widget option may be used in addition to these)
  22 ##
  23 ##  -blinkcolor color                   DEFAULT: yellow
  24 ##      Specifies the background blink color for brace highlighting.
  25 ##      This doubles as the highlight color for the find box.
  26 ##
  27 ##  -blinkrange TCL_BOOLEAN             DEFAULT: 1
  28 ##      When doing electric brace matching, specifies whether to blink
  29 ##      the entire range or just the matching braces.
  30 ##
  31 ##  -blinktime delay                    DEFAULT: 500
  32 ##      For electric brace matching, specifies the amount of time to
  33 ##      blink the background for.
  34 ##
  35 ##  -grabputs TCL_BOOLEAN               DEFAULT: 1
  36 ##      Whether this console should grab the "puts" default output
  37 ##
  38 ##  -lightbrace TCL_BOOLEAN             DEFAULT: 1
  39 ##      Specifies whether to activate electric brace matching.
  40 ##
  41 ##  -lightcmd TCL_BOOLEAN               DEFAULT: 1
  42 ##      Specifies whether to highlight recognized commands.
  43 ##
  44 ##  -proccolor color                    DEFAULT: darkgreen
  45 ##      Specifies the color to highlight recognized procs.
  46 ##
  47 ##  -promptcolor color                  DEFAULT: brown
  48 ##      Specifies the prompt color.
  49 ##
  50 ##  -stdincolor color                   DEFAULT: black
  51 ##      Specifies the color for "stdin".
  52 ##      This doubles as the console foreground color.
  53 ##
  54 ##  -stdoutcolor color                  DEFAULT: blue
  55 ##      Specifies the color for "stdout".
  56 ##
  57 ##  -stderrcolor color                  DEFAULT: red
  58 ##      Specifies the color for "stderr".
  59 ##
  60 ##  -showmultiple TCL_BOOLEAN           DEFAULT: 1
  61 ##      For file/proc/var completion, specifies whether to display
  62 ##      completions when multiple choices are possible.
  63 ##
  64 ##  -showmenu TCL_BOOLEAN               DEFAULT: 1
  65 ##      Specifies whether to show the menubar.
  66 ##
  67 ##  -subhistory TCL_BOOLEAN             DEFAULT: 1
  68 ##      Specifies whether to allow substitution in the history.
  69 ##
  70 ## RETURNS: the window pathname
  71 ##
  72 ## BINDINGS (these are the bindings for Console, used in the text widget)
  73 ##
  74 ## <<Console_ExpandFile>>       <Key-Tab>
  75 ## <<Console_ExpandProc>>       <Control-Shift-Key-P>
  76 ## <<Console_ExpandVar>>        <Control-Shift-Key-V>
  77 ## <<Console_Tab>>              <Control-Key-i>
  78 ## <<Console_Eval>>             <Key-Return> <Key-KP_Enter>
  79 ##
  80 ## <<Console_Clear>>            <Control-Key-l>
  81 ## <<Console_KillLine>>         <Control-Key-k>
  82 ## <<Console_Transpose>>        <Control-Key-t>
  83 ## <<Console_ClearLine>>        <Control-Key-u>
  84 ## <<Console_SaveCommand>>      <Control-Key-z>
  85 ##
  86 ## <<Console_Previous>>         <Key-Up>
  87 ## <<Console_Next>>             <Key-Down>
  88 ## <<Console_NextImmediate>>    <Control-Key-n>
  89 ## <<Console_PreviousImmediate>>        <Control-Key-p>
  90 ## <<Console_PreviousSearch>>   <Control-Key-r>
  91 ## <<Console_NextSearch>>       <Control-Key-s>
  92 ##
  93 ## <<Console_Exit>>             <Control-Key-q>
  94 ## <<Console_New>>              <Control-Key-N>
  95 ## <<Console_Close>>            <Control-Key-w>
  96 ## <<Console_About>>            <Control-Key-A>
  97 ## <<Console_Help>>             <Control-Key-H>
  98 ## <<Console_Find>>             <Control-Key-F>
  99 ##
 100 ## METHODS
 101 ##      These are the methods that the console megawidget recognizes.
 102 ##
 103 ## configure ?option? ?value option value ...?
 104 ## cget option
 105 ##      Standard tk widget routines.
 106 ##
 107 ## load ?filename?
 108 ##      Loads the named file into the current interpreter.
 109 ##      If no file is specified, it pops up the file requester.
 110 ##
 111 ## save ?filename?
 112 ##      Saves the console buffer to the named file.
 113 ##      If no file is specified, it pops up the file requester.
 114 ##
 115 ## clear ?percentage?
 116 ##      Clears a percentage of the console buffer (1-100).  If no
 117 ##      percentage is specified, the entire buffer is cleared.
 118 ##
 119 ## error
 120 ##      Displays the last error in the interpreter in a dialog box.
 121 ##
 122 ## hide
 123 ##      Withdraws the console from the screen
 124 ##
 125 ## history ?-newline?
 126 ##      Prints out the history without numbers (basically providing a
 127 ##      list of the commands you've used).
 128 ##
 129 ## show
 130 ##      Deiconifies and raises the console
 131 ##
 132 ## subwidget widget
 133 ##      Returns the true widget path of the specified widget.  Valid
 134 ##      widgets are console, yscrollbar, menubar.
 135 ##
 136 ## NAMESPACE & STATE
 137 ##      The megawidget creates a global array with the classname, and a
 138 ## global array which is the name of each megawidget created.  The latter
 139 ## array is deleted when the megawidget is destroyed.
 140 ##      The procedure console and those beginning with Console are
 141 ## used.  Also, when a widget is created, commands named .$widgetname
 142 ## and Console$widgetname are created.
 143 ##
 144 ## EXAMPLE USAGE:
 145 ##
 146 ## console .con -height 20 -showmenu false
 147 ## pack .con -fill both -expand 1
 148 ##------------------------------------------------------------------------
 149
 150 package require Widget 1.0
 151 set CONSOLE_VERSION 1.51
 152 package provide Console $CONSOLE_VERSION
 153
 154 foreach pkg [info loaded {}] {
 155     set file [lindex $pkg 0]
 156     set name [lindex $pkg 1]
 157     if {![catch {set version [package require $name]}]} {
 158         if {[string match {} [package ifneeded $name $version]]} {
 159             package ifneeded $name $version "load [list $file $name]"
 160         }
 161     }
 162 }
 163 catch {unset file name version}
 164
 165 set Console(WWW) [expr [info exists embed_args] || [info exists browser_args]]
 166
 167 array set Console {
 168     type                frame
 169     base                {text console console {-wrap char -setgrid 1 \
 170             -yscrollcommand [list $data(yscrollbar) set] \
 171             -foreground $data(-stdincolor)}}
 172     components          {
 173         {frame menubar menubar {-relief raised -bd 1}}
 174         {scrollbar yscrollbar sy {-takefocus 0 -bd 1 \
 175                 -command [list $data(console) yview]}}
 176     }
 177
 178     -blinkcolor         {blinkColor     BlinkColor      \#FFFF00}
 179     -proccolor          {procColor      ProcColor       \#008800}
 180     -promptcolor        {promptColor    PromptColor     \#8F4433}
 181     -stdincolor         {stdinColor     StdinColor      \#000000}
 182     -stdoutcolor        {stdoutColor    StdoutColor     \#0000FF}
 183     -stderrcolor        {stderrColor    StderrColor     \#FF0000}
 184     -varcolor           {varColor       VarColor        \#FFC0D0}
 185
 186     -blinkrange         {blinkRange     BlinkRange      1}
 187     -blinktime          {blinkTime      BlinkTime       500}
 188     -grabputs           {grabPuts       GrabPuts        1}
 189     -lightbrace         {lightBrace     LightBrace      1}
 190     -lightcmd           {lightCmd       LightCmd        1}
 191     -showmultiple       {showMultiple   ShowMultiple    1}
 192     -showmenu           {showMenu       ShowMenu        1}
 193     -subhistory         {subhistory     SubHistory      1}
 194
 195     release     {July 23 1997}
 196     contact     "jeff.hobbs@acm.org"
 197     docs        "http://www.cs.uoregon.edu/research/tcl/script/tkcon/"
 198     slavealias  { console }
 199     slaveprocs  { alias dir dump lremove puts echo unknown tcl_unknown which }
 200 }
 201 if {![info exists Console(active)]} { set Console(active) {} }
 202 set Console(version) $CONSOLE_VERSION
 203
 204 if {$Console(WWW)} {
 205     set Console(-prompt) {prompt        Prompt  {[history nextid] % }}
 206 } else {
 207     set Console(-prompt) {prompt        Prompt  \
 208             {([file tail [pwd]]) [history nextid] % }}
 209 }
 210
 211 # Create this to make sure there are registered in auto_mkindex
 212 # these must come before the [widget create ...]
 213 proc Console args {}
 214 proc console args {}
 215 widget create Console
 216
 217 array set ConsoleDialog {
 218     type        toplevel
 219     base        console
 220
 221     version     1.11
 222 }
 223 # Create this to make sure there are registered in auto_mkindex
 224 # these must come before the [widget create ...]
 225 proc ConsoleDialog args {}
 226 proc consoledialog args {}
 227 proc console_dialog args {}
 228 widget create ConsoleDialog
 229 interp alias {} console_dialog {} ConsoleDialog
 230
 231 ;proc ConsoleDialog:construct {w} {
 232     upvar \#0 $w data ConsoleDialog class
 233
 234     wm title $w "Console Dialog $class(version)"
 235
 236     grid $data(console) -in $w -sticky news
 237     grid columnconfig $w 0 -weight 1
 238     grid rowconfig $w 0 -weight 1
 239 }
 240
 241 ;proc ConsoleDialog:configure {w args} {
 242     ## We have nothing to configure
 243     return
 244     upvar \#0 $w data
 245     set truth {^(1|yes|true|on)$}
 246     foreach {key val} $args {
 247         switch -- $key {
 248         }
 249     }
 250 }
 251
 252 ;proc ConsoleDialog_hide w {
 253     if {[winfo exists $w]} { wm withdraw $w }
 254 }
 255
 256 ;proc ConsoleDialog_show w {
 257     if {[winfo exists $w]} { wm deiconify $w; raise $w }
 258 }
 259
 260 ## console -
 261 # ARGS: w       - widget pathname of the Console console
 262 #       args
 263 # Calls:        ConsoleInitUI
 264 # Outputs:      errors found in Console resource file
 265 ##
 266 ;proc Console:construct {w} {
 267     upvar \#0 $w data
 268
 269     global auto_path tcl_pkgPath tcl_interactive
 270     set tcl_interactive 0
 271
 272     ## Private variables
 273     array set data {
 274         app {} appname {} apptype {} namesp {} deadapp 0
 275         cmdbuf {} cmdsave {} errorInfo {}
 276         event 1 histid 0 find {} find,case 0 find,reg 0
 277     }
 278
 279     if {![info exists tcl_pkgPath]} {
 280         set dir [file join [file dirname [info nameofexec]] lib]
 281         if {[string compare {} [info commands @scope]]} {
 282             set dir [file join $dir itcl]
 283         }
 284         catch {source [file join $dir pkgIndex.tcl]}
 285     }
 286     catch {tclPkgUnknown dummy-name dummy-version}
 287
 288     ConsoleInitMenus $w
 289
 290     grid $data(menubar) - -sticky ew
 291     grid $data(console) $data(yscrollbar) -sticky news
 292     grid columnconfig $w 0 -weight 1
 293     grid rowconfig $w 1 -weight 1
 294
 295     Console:prompt $w "console display active\n"
 296
 297     set c $data(console)
 298     foreach col {prompt stdout stderr stdin proc} {
 299         $c tag configure $col -foreground $data(-${col}color)
 300     }
 301     $c tag configure var -background $data(-varcolor)
 302     $c tag configure blink -background $data(-blinkcolor)
 303     $c tag configure find -background $data(-blinkcolor)
 304
 305 }
 306
 307 ;proc Console:init {w} {
 308     upvar \#0 $w data Console class
 309     bind $w <Destroy> [bind $class(class) <Destroy>]
 310     bindtags $w [list $w [winfo toplevel $w] all]
 311     set c $data(console)
 312     bindtags $c [list $c Console PostConsole $w all]
 313     if {$data(-grabputs) && [lsearch $class(active) $c] == -1} {
 314         set class(active) [linsert $class(active) 0 $c]
 315     }
 316 }
 317
 318 ;proc Console:destroy w {
 319     upvar \#0 $w data Console class
 320     set class(active) [lremove $class(active) $data(console)]
 321 }
 322
 323 ;proc Console:configure { W args } {
 324     upvar \#0 $W data
 325     global Console
 326
 327     set truth {^(1|yes|true|on)$}
 328     set c $data(console)
 329     foreach {key val} $args {
 330         switch -- $key {
 331             -blinkcolor {
 332                 $c tag config blink -background $val
 333                 $c tag config find -background $val
 334             }
 335             -proccolor   { $c tag config proc   -foreground $val }
 336             -promptcolor { $c tag config prompt -foreground $val }
 337             -stdincolor  {
 338                 $c tag config stdin -foreground $val
 339                 $c config -foreground $val
 340             }
 341             -stdoutcolor { $c tag config stdout -foreground $val }
 342             -stderrcolor { $c tag config stderr -foreground $val }
 343
 344             -blinktime          {
 345                 if {![regexp {[0-9]+} $val]} {
 346                     return -code error "$key option requires an integer value"
 347                 } elseif {$val < 100} {
 348                     return -code error "$key option must be greater than 100"
 349                 }
 350             }
 351             -grabputs   {
 352                 if {[set val [regexp -nocase $truth $val]]} {
 353                     set Console(active) [linsert $Console(active) 0 $c]
 354                 } else {
 355                     set Console(active) [lremove -all $Console(active) $c]
 356                 }
 357             }
 358             -prompt             {
 359                 if {[catch {uplevel \#0 [list subst $val]} err]} {
 360                     return -code error "\"$val\" threw an error:\n$err"
 361                 }
 362             }
 363             -showmenu   {
 364                 if {[set val [regexp -nocase $truth $val]]} {
 365                     grid $data(menubar)
 366                 } else {
 367                     grid remove $data(menubar)
 368                 }
 369             }
 370             -lightbrace -
 371             -lightcmd   -
 372             -showmultiple -
 373             -subhistory { set val [regexp -nocase $truth $val] }
 374         }
 375         set data($key) $val
 376     }
 377 }
 378
 379 ;proc Console:exit {w args} {
 380     exit
 381 }
 382
 383 ## ConsoleEval - evaluates commands input into console window
 384 ## This is the first stage of the evaluating commands in the console.
 385 ## They need to be broken up into consituent commands (by ConsoleCmdSep) in
 386 ## case a multiple commands were pasted in, then each is eval'ed (by
 387 ## ConsoleEvalCmd) in turn.  Any uncompleted command will not be eval'ed.
 388 # ARGS: w       - console text widget
 389 # Calls:        ConsoleCmdGet, ConsoleCmdSep, ConsoleEvalCmd
 390 ##
 391 ;proc ConsoleEval {w} {
 392     set incomplete [ConsoleCmdSep [ConsoleCmdGet $w] cmds last]
 393     $w mark set insert end-1c
 394     $w insert end \n
 395     if {[llength $cmds]} {
 396         foreach c $cmds {ConsoleEvalCmd $w $c}
 397         $w insert insert $last {}
 398     } elseif {!$incomplete} {
 399         ConsoleEvalCmd $w $last
 400     }
 401     $w see insert
 402 }
 403
 404 ## ConsoleEvalCmd - evaluates a single command, adding it to history
 405 # ARGS: w       - console text widget
 406 #       cmd     - the command to evaluate
 407 # Calls:        Console:prompt
 408 # Outputs:      result of command to stdout (or stderr if error occured)
 409 # Returns:      next event number
 410 ##
 411 ;proc ConsoleEvalCmd {w cmd} {
 412     ## HACK to get $W as we need it
 413     set W [winfo parent $w]
 414     upvar \#0 $W data
 415
 416     $w mark set output end
 417     if {[string compare {} $cmd]} {
 418         set code 0
 419         if {$data(-subhistory)} {
 420             set ev [ConsoleEvalSlave history nextid]
 421             incr ev -1
 422             if {[string match !! $cmd]} {
 423                 set code [catch {ConsoleEvalSlave history event $ev} cmd]
 424                 if {!$code} {$w insert output $cmd\n stdin}
 425             } elseif {[regexp {^!(.+)$} $cmd dummy evnt]} {
 426                 ## Check last event because history event is broken
 427                 set code [catch {ConsoleEvalSlave history event $ev} cmd]
 428                 if {!$code && ![string match ${evnt}* $cmd]} {
 429                     set code [catch {ConsoleEvalSlave history event $evnt} cmd]
 430                 }
 431                 if {!$code} {$w insert output $cmd\n stdin}
 432             } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
 433                 set code [catch {ConsoleEvalSlave history event $ev} cmd]
 434                 if {!$code} {
 435                     regsub -all -- $old $cmd $new cmd
 436                     $w insert output $cmd\n stdin
 437                 }
 438             }
 439         }
 440         if {$code} {
 441             $w insert output $cmd\n stderr
 442         } else {
 443             ConsoleEvalSlave history add $cmd
 444             if {[catch {ConsoleEvalAttached $cmd} res]} {
 445                 if {[catch {ConsoleEvalAttached {set errorInfo}} err]} {
 446                     set data(errorInfo) "Error getting errorInfo:\n$err"
 447                 } else {
 448                     set data(errorInfo) $err
 449                 }
 450                 $w insert output $res\n stderr
 451             } elseif {[string compare {} $res]} {
 452                 $w insert output $res\n stdout
 453             }
 454         }
 455     }
 456     Console:prompt $W
 457     set data(event) [ConsoleEvalSlave history nextid]
 458 }
 459
 460 ## ConsoleEvalSlave - evaluates the args in the associated slave
 461 ## args should be passed to this procedure like they would be at
 462 ## the command line (not like to 'eval').
 463 # ARGS: args    - the command and args to evaluate
 464 ##
 465 ;proc ConsoleEvalSlave {args} {
 466     uplevel \#0 $args
 467 }
 468
 469 ## ConsoleEvalAttached
 470 ##
 471 ;proc ConsoleEvalAttached {args} {
 472     uplevel \#0 eval $args
 473 }
 474
 475 ## ConsoleCmdGet - gets the current command from the console widget
 476 # ARGS: w       - console text widget
 477 # Returns:      text which compromises current command line
 478 ##
 479 ;proc ConsoleCmdGet w {
 480     if {[string match {} [$w tag nextrange prompt limit end]]} {
 481         $w tag add stdin limit end-1c
 482         return [$w get limit end-1c]
 483     }
 484 }
 485
 486 ## ConsoleCmdSep - separates multiple commands into a list and remainder
 487 # ARGS: cmd     - (possible) multiple command to separate
 488 #       list    - varname for the list of commands that were separated.
 489 #       rmd     - varname of any remainder (like an incomplete final command).
 490 #               If there is only one command, it's placed in this var.
 491 # Returns:      constituent command info in varnames specified by list & rmd.
 492 ##
 493 ;proc ConsoleCmdSep {cmd list last} {
 494     upvar 1 $list cmds $last inc
 495     set inc {}
 496     set cmds {}
 497     foreach c [split [string trimleft $cmd] \n] {
 498         if {[string compare $inc {}]} {
 499             append inc \n$c
 500         } else {
 501             append inc [string trimleft $c]
 502         }
 503         if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
 504             if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
 505             set inc {}
 506         }
 507     }
 508     set i [string compare $inc {}]
 509     if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
 510         set inc [lindex $cmds end]
 511         set cmds [lreplace $cmds end end]
 512     }
 513     return $i
 514 }
 515
 516 ## Console:prompt - displays the prompt in the console widget
 517 # ARGS: w       - console text widget
 518 # Outputs:      prompt (specified in data(-prompt)) to console
 519 ##
 520 ;proc Console:prompt {W {pre {}} {post {}} {prompt {}}} {
 521     upvar \#0 $W data
 522
 523     set w $data(console)
 524     if {[string compare {} $pre]} { $w insert end $pre stdout }
 525     set i [$w index end-1c]
 526     if {[string compare {} $data(appname)]} {
 527         $w insert end ">$data(appname)< " prompt
 528     }
 529     if {[string compare {} $prompt]} {
 530         $w insert end $prompt prompt
 531     } else {
 532         $w insert end [ConsoleEvalSlave subst $data(-prompt)] prompt
 533     }
 534     $w mark set output $i
 535     $w mark set insert end
 536     $w mark set limit insert
 537     $w mark gravity limit left
 538     if {[string compare {} $post]} { $w insert end $post stdin }
 539     $w see end
 540 }
 541
 542 ## ConsoleAbout - gives about info for Console
 543 ##
 544 ;proc ConsoleAbout W {
 545     global Console
 546
 547     set w $W.about
 548     if {[winfo exists $w]} {
 549         wm deiconify $w
 550     } else {
 551         global tk_patchLevel tcl_patchLevel tcl_platform
 552         toplevel $w
 553         wm title $w "About Console v$Console(version)"
 554         button $w.b -text Dismiss -command [list wm withdraw $w]
 555         text $w.text -height 9 -bd 1 -width 60
 556         pack $w.b -fill x -side bottom
 557         pack $w.text -fill both -side left -expand 1
 558         $w.text tag config center -justify center
 559         global tcl_platform
 560         if {[string compare unix $tcl_platform(platform)] || \
 561                 [info tclversion] >= 8} {
 562             $w.text tag config title -justify center -font {Courier 18 bold}
 563         } else {
 564             $w.text tag config title -justify center -font *Courier*Bold*18*
 565         }
 566         $w.text insert 1.0 "About Console v$Console(version)" title \
 567                 "\n\nCopyright 1995-1997 Jeffrey Hobbs, $Console(contact)\
 568                 \nhttp://www.cs.uoregon.edu/~jhobbs/\
 569                 \nRelease Date: v$Console(version), $Console(release)\
 570                 \nDocumentation available at:\n$Console(docs)\
 571                 \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
 572     }
 573 }
 574
 575 ## ConsoleInitMenus - inits the menubar and popup for the console
 576 # ARGS: W       - console megawidget
 577 ##
 578 ;proc ConsoleInitMenus W {
 579     upvar \#0 $W data
 580
 581     set w    $data(menubar)
 582     set text $data(console)
 583
 584     if {[catch {menu $w.pop -tearoff 0}]} {
 585         label $w.label -text "Menus not available in plugin mode"
 586         pack $w.label
 587         return
 588     }
 589     bind [winfo toplevel $w] <Button-3> "tk_popup $w.pop %X %Y"
 590     bind $text <Button-3> "tk_popup $w.pop %X %Y"
 591
 592     ## Console Menu
 593     ## FIX - get the attachment stuff working
 594     set n cons
 595     set l "Console"
 596     pack [menubutton $w.$n  -text $l -un 0 -menu $w.$n.m] -side left
 597     $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
 598     foreach m [list [menu $w.$n.m -disabledfore $data(-promptcolor)] \
 599             [menu $w.pop.$n -disabledfore $data(-promptcolor)]] {
 600         $m add command -label "Console $W" -state disabled
 601         $m add command -label "Clear Console " -un 1 \
 602                 -acc [event info <<Console_Clear>>] \
 603                 -com [list Console_clear $W]
 604         $m add command -label "Load File" -und 0 \
 605                 -command [list Console_load $W]
 606         $m add cascade -label "Save ..."  -und 0 -menu $m.save
 607         $m add separator
 608         $m add cascade -label "Attach Console"  -und 7 -menu $m.apps \
 609                 -state disabled
 610         $m add cascade -label "Attach Namespace" -und 7 -menu $m.name \
 611                 -state disabled
 612         $m add separator
 613         $m add command -label "Exit" -un 1 -acc [event info <<Console_Exit>>] \
 614                 -command [list Console:exit $W]
 615
 616         ## Save Menu
 617         ##
 618         set s $m.save
 619         menu $s -disabledforeground $data(-promptcolor) -tearoff 0
 620         $s add command -label "All"     -und 0 \
 621                 -command [list Console_save $W all]
 622         $s add command -label "History" -und 0 \
 623                 -command [list Console_save $W history]
 624         $s add command -label "Stdin"   -und 3 \
 625                 -command [list Console_save $W stdin]
 626         $s add command -label "Stdout"  -und 3 \
 627                 -command [list Console_save $W stdout]
 628         $s add command -label "Stderr"  -und 3 \
 629                 -command [list Console_save $W stderr]
 630
 631         ## Attach Console Menu
 632         ##
 633         menu $m.apps -disabledforeground $data(-promptcolor) \
 634                 -postcommand [list ConsoleAttachMenu $m.apps]
 635
 636         ## Attach Interpreter Menu
 637         ##
 638         menu $m.int -disabledforeground $data(-promptcolor) -tearoff 0 \
 639                 -postcommand [list ConsoleAttachMenu $m.int interp]
 640
 641         ## Attach Namespace Menu
 642         ##
 643         menu $m.name -disabledforeground $data(-promptcolor) -tearoff 0 \
 644                 -postcommand [list ConsoleAttachMenu $m.name namespace]
 645     }
 646
 647     ## Edit Menu
 648     ##
 649     set n edit
 650     set l "Edit"
 651     pack [menubutton $w.$n  -text $l -un 0 -menu $w.$n.m] -side left
 652     $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
 653     foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
 654         $m add command -label "Cut"   -un 1 \
 655                 -acc [lindex [event info <<Cut>>] 0] \
 656                 -command [list ConsoleCut $text]
 657         $m add command -label "Copy"  -un 1 \
 658                 -acc [lindex [event info <<Copy>>] 0] \
 659                 -command [list ConsoleCopy $text]
 660         $m add command -label "Paste" -un 0 \
 661                 -acc [lindex [event info <<Paste>>] 0] \
 662                 -command [list ConsolePaste $text]
 663         $m add separator
 664         $m add command -label "Find"  -un 0 \
 665                 -acc [lindex [event info <<Console_Find>>] 0] \
 666                 -command [list ConsoleFindBox $W]
 667         $m add separator
 668         $m add command -label "Last Error" -un 0 -command [list $W error]
 669     }
 670
 671     ## Prefs Menu
 672     ##
 673     set n pref
 674     set l "Prefs"
 675     pack [menubutton $w.$n  -text $l -un 0 -menu $w.$n.m] -side left
 676     $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
 677     foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
 678         $m add checkbutton -label "Brace Highlighting" -var $W\(-lightbrace\)
 679         $m add checkbutton -label "Command Highlighting" -var $W\(-lightcmd\)
 680         $m add checkbutton -label "Grab Puts Output" -var $W\(-grabputs\) \
 681                 -command "Console:configure $W \
 682                 -grabputs \[set ${W}(-grabputs)\]"
 683         $m add checkbutton -label "History Substitution" -var $W\(-subhistory\)
 684         $m add checkbutton -label "Show Multiple Matches" \
 685                 -var $W\(-showmultiple\)
 686         $m add checkbutton -label "Show Menubar" -var $W\(-showmenu\) \
 687                 -command "Console:configure $W \
 688                 -showmenu \[set ${W}(-showmenu)\]"
 689     }
 690
 691     ## History Menu
 692     ##
 693     set n hist
 694     set l "History"
 695     pack [menubutton $w.$n  -text $l -un 0 -menu $w.$n.m] -side left
 696     $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
 697     foreach m [list $w.$n.m $w.pop.$n] {
 698         menu $m -disabledfore $data(-promptcolor) \
 699                 -postcommand [list ConsoleHistoryMenu $W $m]
 700     }
 701
 702     ## Help Menu
 703     ##
 704     set n help
 705     set l "Help"
 706     pack [menubutton $w.$n  -text $l -un 0 -menu $w.$n.m] -side right
 707     $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
 708     foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
 709         $m config -disabledfore $data(-promptcolor)
 710         $m add command -label "About " -un 0 \
 711                 -acc [event info <<Console_About>>] \
 712                 -command [list ConsoleAbout $W]
 713     }
 714
 715     bind $W <<Console_Exit>>    [list Console:exit $W]
 716     bind $W <<Console_About>>   [list ConsoleAbout $W]
 717     bind $W <<Console_Help>>    [list ConsoleHelp $W]
 718     bind $W <<Console_Find>>    [list ConsoleFindBox $W]
 719
 720     ## Menu items need null PostConsole bindings to avoid the TagProc
 721     ##
 722     foreach ev [bind $W] {
 723         bind PostConsole $ev {
 724             # empty
 725         }
 726     }
 727 }
 728
 729 ## ConsoleHistoryMenu - dynamically build the menu for attached interpreters
 730 ##
 731 # ARGS: w       - menu widget
 732 ##
 733 ;proc ConsoleHistoryMenu {W w} {
 734     upvar \#0 $W data
 735
 736     if {![winfo exists $w]} return
 737     set id [ConsoleEvalSlave history nextid]
 738     if {$data(histid)==$id} return
 739     set data(histid) $id
 740     $w delete 0 end
 741     set con $data(console)
 742     while {($id>$data(histid)-10) && \
 743             ![catch {ConsoleEvalSlave history event [incr id -1]} tmp]} {
 744         set lbl [lindex [split $tmp "\n"] 0]
 745         if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... }
 746         $w add command -label "$id: $lbl" -command "
 747         $con delete limit end
 748         $con insert limit [list $tmp]
 749         $con see end
 750         ConsoleEval $con
 751         "
 752     }
 753 }
 754
 755 ## ConsoleFindBox - creates minimal dialog interface to ConsoleFind
 756 # ARGS: w       - text widget
 757 #       str     - optional seed string for data(find)
 758 ##
 759 ;proc ConsoleFindBox {W {str {}}} {
 760     upvar \#0 $W data
 761
 762     set t $data(console)
 763     set base $W.find
 764     if {![winfo exists $base]} {
 765         toplevel $base
 766         wm withdraw $base
 767         wm title $base "Console Find"
 768
 769         pack [frame $base.f] -fill x -expand 1
 770         label $base.f.l -text "Find:"
 771         entry $base.f.e -textvar $W\(find\)
 772         pack [frame $base.opt] -fill x
 773         checkbutton $base.opt.c -text "Case Sensitive" -var $W\(find,case\)
 774         checkbutton $base.opt.r -text "Use Regexp" -var $W\(find,reg\)
 775         pack $base.f.l -side left
 776         pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
 777         pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
 778         pack [frame $base.btn] -fill both
 779         button $base.btn.fnd -text "Find" -width 6
 780         button $base.btn.clr -text "Clear" -width 6
 781         button $base.btn.dis -text "Dismiss" -width 6
 782         eval pack [winfo children $base.btn] -padx 4 -pady 2 \
 783                 -side left -fill both
 784
 785         focus $base.f.e
 786
 787         bind $base.f.e <Return> [list $base.btn.fnd invoke]
 788         bind $base.f.e <Escape> [list $base.btn.dis invoke]
 789     }
 790     $base.btn.fnd config -command "Console_find $W \$data(find) \
 791             -case \$data(find,case) -reg \$data(find,reg)"
 792     $base.btn.clr config -command "
 793     $t tag remove find 1.0 end
 794     set data(find) {}
 795     "
 796     $base.btn.dis config -command "
 797     $t tag remove find 1.0 end
 798     wm withdraw $base
 799     "
 800     if {[string compare {} $str]} {
 801         set data(find) $str
 802         $base.btn.fnd invoke
 803     }
 804
 805     if {[string compare normal [wm state $base]]} {
 806         wm deiconify $base
 807     } else { raise $base }
 808     $base.f.e select range 0 end
 809 }
 810
 811 ## Console_find - searches in text widget for $str and highlights it
 812 ## If $str is empty, it just deletes any highlighting
 813 # ARGS: W       - console widget
 814 #       str     - string to search for
 815 #       -case   TCL_BOOLEAN     whether to be case sensitive    DEFAULT: 0
 816 #       -regexp TCL_BOOLEAN     whether to use $str as pattern  DEFAULT: 0
 817 ##
 818 ;proc ConsoleFind {W str args} {
 819     upvar \#0 $W data
 820     set t $data(console)
 821     $t tag remove find 1.0 end
 822     set truth {^(1|yes|true|on)$}
 823     set opts  {}
 824     foreach {key val} $args {
 825         switch -glob -- $key {
 826             -c* { if {[regexp -nocase $truth $val]} { set case 1 } }
 827             -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } }
 828             default { return -code error "Unknown option $key" }
 829         }
 830     }
 831     if {![info exists case]} { lappend opts -nocase }
 832     if {[string match {} $str]} return
 833     $t mark set findmark 1.0
 834     while {[string compare {} [set ix [eval $t search $opts -count numc -- \
 835             [list $str] findmark end]]]} {
 836         $t tag add find $ix ${ix}+${numc}c
 837         $t mark set findmark ${ix}+1c
 838     }
 839     catch {$t see find.first}
 840     return [expr [llength [$t tag ranges find]]/2]
 841 }
 842
 843 ## Console:savecommand - saves a command in a buffer for later retrieval
 844 #
 845 ##
 846 ;proc Console:savecommand {w} {
 847     upvar \#0 [winfo parent $w] data
 848
 849     set tmp $data(cmdsave)
 850     set data(cmdsave) [ConsoleCmdGet $w]
 851     if {[string match {} $data(cmdsave)]} {
 852         set data(cmdsave) $tmp
 853     } else {
 854         $w delete limit end-1c
 855     }
 856     $w insert limit $tmp
 857     $w see end
 858 }
 859
 860 ## Console_load - sources a file into the console
 861 # ARGS: fn      - (optional) filename to source in
 862 # Returns:      selected filename ({} if nothing was selected)
 863 ##
 864 ;proc Console_load {W {fn ""}} {
 865     set types {
 866         {{Tcl Files}    {.tcl .tk}}
 867         {{Text Files}   {.txt}}
 868         {{All Files}    *}
 869     }
 870     if {
 871         [string match {} $fn] &&
 872         ([catch {tk_getOpenFile -filetypes $types \
 873             -title "Source File"} fn] || [string match {} $fn])
 874     } { return }
 875     ConsoleEvalAttached [list source $fn]
 876 }
 877
 878 ## Console_save - saves the console buffer to a file
 879 ## This does not eval in a slave because it's not necessary
 880 # ARGS: w       - console text widget
 881 #       fn      - (optional) filename to save to
 882 ##
 883 ;proc Console_save {W {fn ""} {type ""}} {
 884     upvar \#0 $W data
 885
 886     set c $data(console)
 887     if {![regexp -nocase {^(all|history|stdin|stdout|stderr)$} $type]} {
 888         array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
 889         ## Allow user to specify what kind of stuff to save
 890         set type [tk_dialog $W.savetype "Save Type" \
 891                 "What part of the console text do you want to save?" \
 892                 questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
 893         if {$type == 5 || $type == -1} return
 894         set type $s($type)
 895     }
 896     if {[string match {} $fn]} {
 897         set types {
 898             {{Text Files}       {.txt}}
 899             {{Tcl Files}        {.tcl .tk}}
 900             {{All Files}        *}
 901         }
 902         if {[catch {tk_getSaveFile -filetypes $types -title "Save $type"} fn] \
 903                 || [string match {} $fn]} return
 904     }
 905     set type [string tolower $type]
 906     switch $type {
 907         stdin - stdout - stderr {
 908             set data {}
 909             foreach {first last} [$c tag ranges $type] {
 910                 lappend data [$c get $first $last]
 911             }
 912             set data [join $data \n]
 913         }
 914         history         { set data [Console_history $W] }
 915         all - default   { set data [$c get 1.0 end-1c] }
 916     }
 917     if {[catch {open $fn w} fid]} {
 918         return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
 919     }
 920     puts $fid $data
 921     close $fid
 922 }
 923
 924 ## clear - clears the buffer of the console (not the history though)
 925 ##
 926 ;proc Console_clear {W {pcnt 100}} {
 927     upvar \#0 $W data
 928
 929     set data(tmp) [ConsoleCmdGet $data(console)]
 930     if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
 931         return -code error \
 932                 "invalid percentage to clear: must be 1-100 (100 default)"
 933     } elseif {$pcnt == 100} {
 934         $data(console) delete 1.0 end
 935     } else {
 936         set tmp [expr $pcnt/100.0*[$data(console) index end]]
 937         $data(console) delete 1.0 "$tmp linestart"
 938     }
 939     Console:prompt $W {} $data(tmp)
 940 }
 941
 942 ;proc Console_error {W} {
 943     ## Outputs stack caused by last error.
 944     upvar \#0 $W data
 945     set info $data(errorInfo)
 946     if {[string match {} $info]} { set info {errorInfo empty} }
 947     catch {destroy $W.error}
 948     set w [toplevel $W.error]
 949     wm title $w "Console Last Error"
 950     button $w.close -text Dismiss -command [list destroy $w]
 951     scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
 952     text $w.text -yscrollcommand [list $w.sy set]
 953     pack $w.close -side bottom -fill x
 954     pack $w.sy -side right -fill y
 955     pack $w.text -fill both -expand 1
 956     $w.text insert 1.0 $info
 957     $w.text config -state disabled
 958 }
 959
 960 ## Console_event - searches for history based on a string
 961 ## Search forward (next) if $int>0, otherwise search back (prev)
 962 # ARGS: W       - console widget
 963 ##
 964 ;proc Console_event {W int {str {}}} {
 965     upvar \#0 $W data
 966
 967     if {!$int} return
 968     set w $data(console)
 969
 970     set nextid [ConsoleEvalSlave history nextid]
 971     if {[string compare {} $str]} {
 972         ## String is not empty, do an event search
 973         set event $data(event)
 974         if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str }
 975         set len [string len $data(cmdbuf)]
 976         incr len -1
 977         if {$int > 0} {
 978             ## Search history forward
 979             while {$event < $nextid} {
 980                 if {[incr event] == $nextid} {
 981                     $w delete limit end
 982                     $w insert limit $data(cmdbuf)
 983                     break
 984                 } elseif {![catch {ConsoleEvalSlave history event $event} res]\
 985                         && ![string compare $data(cmdbuf) \
 986                         [string range $res 0 $len]]} {
 987                     $w delete limit end
 988                     $w insert limit $res
 989                     break
 990                 }
 991             }
 992             set data(event) $event
 993         } else {
 994             ## Search history reverse
 995             while {![catch {ConsoleEvalSlave \
 996                     history event [incr event -1]} res]} {
 997                 if {![string compare $data(cmdbuf) \
 998                         [string range $res 0 $len]]} {
 999                     $w delete limit end
1000                     $w insert limit $res
1001                     set data(event) $event
1002                     break
1003                 }
1004             }
1005         }
1006     } else {
1007         ## String is empty, just get next/prev event
1008         if {$int > 0} {
1009             ## Goto next command in history
1010             if {$data(event) < $nextid} {
1011                 $w delete limit end
1012                 if {[incr data(event)] == $nextid} {
1013                     $w insert limit $data(cmdbuf)
1014                 } else {
1015                     $w insert limit [ConsoleEvalSlave \
1016                             history event $data(event)]
1017                 }
1018             }
1019         } else {
1020             ## Goto previous command in history
1021             if {$data(event) == $nextid} {set data(cmdbuf) [ConsoleCmdGet $w]}
1022             if {[catch {ConsoleEvalSlave \
1023                     history event [incr data(event) -1]} res]} {
1024                 incr data(event)
1025             } else {
1026                 $w delete limit end
1027                 $w insert limit $res
1028             }
1029         }
1030     }
1031     $w mark set insert end
1032     $w see end
1033 }
1034
1035 ;proc Console_history {W args} {
1036     set sub {\2}
1037     if {[string match -n* $args]} { append sub "\n" }
1038     set h [ConsoleEvalSlave history]
1039     regsub -all "( *\[0-9\]+  |\t)(\[^\n\]*\n?)" $h $sub h
1040     return $h
1041 }
1042
1043 ##
1044 ## Some procedures to make up for lack of built-in shell commands
1045 ##
1046
1047 ## puts
1048 ## This allows me to capture all stdout/stderr to the console window
1049 # ARGS: same as usual
1050 # Outputs:      the string with a color-coded text tag
1051 ##
1052 if {![catch {rename puts console_tcl_puts}]} {
1053     ;proc puts args {
1054         global Console
1055         set w [lindex $Console(active) 0]
1056         if {[winfo exists $w]} {
1057             set len [llength $args]
1058             if {$len==1} {
1059                 eval $w insert output $args stdout {\n} stdout
1060                 $w see output
1061             } elseif {$len==2 && [regexp {(stdout|stderr|-nonewline)} \
1062                     [lindex $args 0] junk tmp]} {
1063                 if {[string compare $tmp -nonewline]} {
1064                     eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp
1065                 } else {
1066                     eval $w insert output [lreplace $args 0 0] stdout
1067                 }
1068                 $w see output
1069             } elseif {$len==3 && \
1070                     [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
1071                 if {[string compare [lreplace $args 1 2] -nonewline]} {
1072                     eval $w insert output [lrange $args 1 1] $tmp
1073                 } else {
1074                     eval $w insert output [lreplace $args 0 1] $tmp
1075                 }
1076                 $w see output
1077             } else {
1078                 global errorCode errorInfo
1079                 if {[catch "console_tcl_puts $args" msg]} {
1080                     regsub console_tcl_puts $msg puts msg
1081                     regsub -all console_tcl_puts \
1082                             $errorInfo puts errorInfo
1083                     error $msg
1084                 }
1085                 return $msg
1086             }
1087             if {$len} update
1088         } else {
1089             global errorCode errorInfo
1090             if {[catch "console_tcl_puts $args" msg]} {
1091                 regsub console_tcl_puts $msg puts msg
1092                 regsub -all console_tcl_puts $errorInfo puts errorInfo
1093                 error $msg
1094             }
1095             return $msg
1096         }
1097     }
1098 }
1099
1100 ## echo
1101 ## Relaxes the one string restriction of 'puts'
1102 # ARGS: any number of strings to output to stdout
1103 ##
1104 proc echo args { puts [concat $args] }
1105
1106 ## alias - akin to the csh alias command
1107 ## If called with no args, then it dumps out all current aliases
1108 ## If called with one arg, returns the alias of that arg (or {} if none)
1109 # ARGS: newcmd  - (optional) command to bind alias to
1110 #       args    - command and args being aliased
1111 ##
1112 proc alias {{newcmd {}} args} {
1113     if {[string match {} $newcmd]} {
1114         set res {}
1115         foreach a [interp aliases] {
1116             lappend res [list $a -> [interp alias {} $a]]
1117         }
1118         return [join $res \n]
1119     } elseif {[string match {} $args]} {
1120         interp alias {} $newcmd
1121     } else {
1122         eval interp alias [list {} $newcmd {}] $args
1123     }
1124 }
1125
1126 ## dump - outputs variables/procedure/widget info in source'able form.
1127 ## Accepts glob style pattern matching for the names
1128 # ARGS: type    - type of thing to dump: must be variable, procedure, widget
1129 # OPTS: -nocomplain
1130 #               don't complain if no vars match something
1131 #       -filter pattern
1132 #               specifies a glob filter pattern to be used by the variable
1133 #               method as an array filter pattern (it filters down for
1134 #               nested elements) and in the widget method as a config
1135 #               option filter pattern
1136 #       --      forcibly ends options recognition
1137 # Returns:      the values of the requested items in a 'source'able form
1138 ##
1139 proc dump {type args} {
1140     set whine 1
1141     set code  ok
1142     if {[string match {} $args]} {
1143         ## If no args, assume they gave us something to dump and
1144         ## we'll try anything
1145         set args [list $type]
1146         set type any
1147     }
1148     while {[string match -* $args]} {
1149         switch -glob -- [lindex $args 0] {
1150             -n* { set whine 0; set args [lreplace $args 0 0] }
1151             -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
1152             --  { set args [lreplace $args 0 0]; break }
1153             default {return -code error "unknown option \"[lindex $args 0]\""}
1154         }
1155     }
1156     if {$whine && [string match {} $args]} {
1157         return -code error "wrong \# args: [lindex [info level 0] 0] type\
1158                 ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
1159     }
1160     set res {}
1161     switch -glob -- $type {
1162         c* {
1163             # command
1164             # outpus commands by figuring out, as well as possible, what it is
1165             # this does not attempt to auto-load anything
1166             foreach arg $args {
1167                 if {[string compare {} [set cmds [info comm $arg]]]} {
1168                     foreach cmd [lsort $cmds] {
1169                         if {[lsearch -exact [interp aliases] $cmd] > -1} {
1170                             append res "\#\# ALIAS:   $cmd =>\
1171                                     [interp alias {} $cmd]\n"
1172                         } elseif {[string compare {} [info procs $cmd]]} {
1173                             if {[catch {uplevel dump p -- $cmd} msg] \
1174                                     && $whine} { set code error }
1175                             append res $msg\n
1176                         } else {
1177                             append res "\#\# COMMAND: $cmd\n"
1178                         }
1179                     }
1180                 } elseif {$whine} {
1181                     append res "\#\# No known command $arg\n"
1182                     set code error
1183                 }
1184             }
1185         }
1186         v* {
1187             # variable
1188             # outputs variables value(s), whether array or simple.
1189             if {![info exists fltr]} { set fltr * }
1190             foreach arg $args {
1191                 if {[string match {} \
1192                         [set vars [uplevel info vars [list $arg]]]]} {
1193                     if {[uplevel info exists $arg]} {
1194                         set vars $arg
1195                     } elseif {$whine} {
1196                         append res "\#\# No known variable $arg\n"
1197                         set code error
1198                         continue
1199                     } else { continue }
1200                 }
1201                 foreach var [lsort $vars] {
1202                     upvar $var v
1203                     if {[array exists v]} {
1204                         set nest {}
1205                         append res "array set $var \{\n"
1206                         foreach i [lsort [array names v $fltr]] {
1207                             upvar 0 v\($i\) __ary
1208                             if {[array exists __ary]} {
1209                                 append nest "\#\# NESTED ARRAY ELEMENT: $i\n"
1210                                 append nest "upvar 0 [list $var\($i\)] __ary;\
1211                                         [dump v -filter $fltr __ary]\n"
1212                             } else {
1213                                 append res "    [list $i]\t[list $v($i)]\n"
1214                             }
1215                         }
1216                         append res "\}\n$nest"
1217                     } else {
1218                         append res [list set $var $v]\n
1219                     }
1220                 }
1221             }
1222         }
1223         p* {
1224             # procedure
1225             foreach arg $args {
1226                 if {[string compare {} [set ps [info proc $arg]]] ||
1227                 ([auto_load $arg] &&
1228                 [string compare {} [set ps [info proc $arg]]])} {
1229                     foreach p [lsort $ps] {
1230                         set as {}
1231                         foreach a [info args $p] {
1232                             if {[info default $p $a tmp]} {
1233                                 lappend as [list $a $tmp]
1234                             } else {
1235                                 lappend as $a
1236                             }
1237                         }
1238                         append res [list proc $p $as [info body $p]]\n
1239                     }
1240                 } elseif {$whine} {
1241                     append res "\#\# No known proc $arg\n"
1242                     set code error
1243                 }
1244             }
1245         }
1246         w* {
1247             # widget
1248             ## The user should have Tk loaded
1249             if {[string match {} [info command winfo]]} {
1250                 return -code error "winfo not present, cannot dump widgets"
1251             }
1252             if {![info exists fltr]} { set fltr .* }
1253             foreach arg $args {
1254                 if {[string compare {} [set ws [info command $arg]]]} {
1255                     foreach w [lsort $ws] {
1256                         if {[winfo exists $w]} {
1257                             if {[catch {$w configure} cfg]} {
1258                                 append res "\#\# Widget $w\
1259                                         does not support configure method"
1260                                 set code error
1261                             } else {
1262                                 append res "\#\# [winfo class $w]\
1263                                         $w\n$w configure"
1264                                 foreach c $cfg {
1265                                     if {[llength $c] != 5} continue
1266                                     if {[regexp -nocase -- $fltr $c]} {
1267                                         append res " \\\n\t[list [lindex $c 0]\
1268                                                 [lindex $c 4]]"
1269                                     }
1270                                 }
1271                                 append res \n
1272                             }
1273                         }
1274                     }
1275                 } elseif {$whine} {
1276                     append res "\#\# No known widget $arg\n"
1277                     set code error
1278                 }
1279             }
1280         }
1281         a* {
1282             ## any - try to dump as var, then command, then widget...
1283             if {
1284                 [catch {uplevel dump v -- $args} res] &&
1285                 [catch {uplevel dump c -- $args} res] &&
1286                 [catch {uplevel dump w -- $args} res]
1287             } {
1288                 set res "dump was unable to resolve type for \"$args\""
1289                 set code error
1290             }
1291         }
1292         default {
1293             return -code error "bad [lindex [info level 0] 0] option\
1294                     \"$type\": must be command, procedure, variable, widget"
1295         }
1296     }
1297     return -code $code [string trimr $res \n]
1298 }
1299
1300 ## which - tells you where a command is found
1301 # ARGS: cmd     - command name
1302 # Returns:      where command is found (internal / external / unknown)
1303 ##
1304 proc which cmd {
1305     if {[string compare {} [info commands $cmd]] || \
1306             ([auto_load $cmd] && [string compare {} [info commands $cmd]])} {
1307         if {[lsearch -exact [interp aliases] $cmd] > -1} {
1308             set result "$cmd: aliased to [alias $cmd]"
1309         } elseif {[string compare {} [info procs $cmd]]} {
1310             set result "$cmd: procedure"
1311         } else {
1312             set result "$cmd: command"
1313         }
1314         global auto_index
1315         if {[info exists auto_index($cmd)]} {
1316             ## This tells you where the command MIGHT have come from -
1317             ## not true if the command was redefined interactively or
1318             ## existed before it had to be auto_loaded.  This is just
1319             ## provided as a hint at where it MAY have come from
1320             append result " ($auto_index($cmd))"
1321         }
1322         return $result
1323     } elseif {[string compare {} [auto_execok $cmd]]} {
1324         return [auto_execok $cmd]
1325     } else {
1326         return -code error "$cmd: command not found"
1327     }
1328 }
1329
1330 ## dir - directory list
1331 # ARGS: args    - names/glob patterns of directories to list
1332 # OPTS: -all    - list hidden files as well (Unix dot files)
1333 #       -long   - list in full format "permissions size date filename"
1334 #       -full   - displays / after directories and link paths for links
1335 # Returns:      a directory listing
1336 ##
1337 proc dir {args} {
1338     array set s {
1339         all 0 full 0 long 0
1340         0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
1341     }
1342     while {[string match \-* [lindex $args 0]]} {
1343         set str [lindex $args 0]
1344         set args [lreplace $args 0 0]
1345         switch -glob -- $str {
1346             -a* {set s(all) 1} -f* {set s(full) 1}
1347             -l* {set s(long) 1} -- break
1348             default {
1349                 return -code error "unknown option \"$str\",\
1350                         should be one of: -all, -full, -long"
1351             }
1352         }
1353     }
1354     set sep [string trim [file join . .] .]
1355     if {[string match {} $args]} { set args . }
1356     foreach arg $args {
1357         if {[file isdir $arg]} {
1358             set arg [string trimr $arg $sep]$sep
1359             if {$s(all)} {
1360                 lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
1361             } else {
1362                 lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
1363             }
1364         } else {
1365             lappend out [list [file dirname $arg]$sep \
1366                     [lsort [glob -nocomplain -- $arg]]]
1367         }
1368     }
1369     if {$s(long)} {
1370         set old [clock scan {1 year ago}]
1371         set fmt "%s%9d %s %s\n"
1372         foreach o $out {
1373             set d [lindex $o 0]
1374             append res $d:\n
1375             foreach f [lindex $o 1] {
1376                 file lstat $f st
1377                 set f [file tail $f]
1378                 if {$s(full)} {
1379                     switch -glob $st(type) {
1380                         d* { append f $sep }
1381                         l* { append f "@ -> [file readlink $d$sep$f]" }
1382                         default { if {[file exec $d$sep$f]} { append f * } }
1383                     }
1384                 }
1385                 if {[string match file $st(type)]} {
1386                     set mode -
1387                 } else {
1388                     set mode [string index $st(type) 0]
1389                 }
1390                 foreach j [split [format %o [expr $st(mode)&0777]] {}] {
1391                     append mode $s($j)
1392                 }
1393                 if {$st(mtime)>$old} {
1394                     set cfmt {%b %d %H:%M}
1395                 } else {
1396                     set cfmt {%b %d  %Y}
1397                 }
1398                 append res [format $fmt $mode $st(size) \
1399                         [clock format $st(mtime) -format $cfmt] $f]
1400             }
1401             append res \n
1402         }
1403     } else {
1404         foreach o $out {
1405             set d [lindex $o 0]
1406             append res $d:\n
1407             set i 0
1408             foreach f [lindex $o 1] {
1409                 if {[string len [file tail $f]] > $i} {
1410                     set i [string len [file tail $f]]
1411                 }
1412             }
1413             set i [expr {$i+2+$s(full)}]
1414             ## This gets the number of cols in the Console console widget
1415             set j [expr {66/$i}]
1416             set k 0
1417             foreach f [lindex $o 1] {
1418                 set f [file tail $f]
1419                 if {$s(full)} {
1420                     switch -glob [file type $d$sep$f] {
1421                         d* { append f $sep }
1422                         l* { append f @ }
1423                         default { if {[file exec $d$sep$f]} { append f * } }
1424                     }
1425                 }
1426                 append res [format "%-${i}s" $f]
1427                 if {[incr k]%$j == 0} {set res [string trimr $res]\n}
1428             }
1429             append res \n\n
1430         }
1431     }
1432     return [string trimr $res]
1433 }
1434 interp alias {} ls {} dir -full
1435
1436 ## lremove - remove items from a list
1437 # OPTS: -all    remove all instances of each item
1438 # ARGS: l       a list to remove items from
1439 #       args    items to remove
1440 ##
1441 proc lremove {args} {
1442     set all 0
1443     if {[string match \-a* [lindex $args 0]]} {
1444         set all 1
1445         set args [lreplace $args 0 0]
1446     }
1447     set l [lindex $args 0]
1448     foreach i [join [lreplace $args 0 0]] {
1449         if {[set ix [lsearch -exact $l $i]] == -1} continue
1450         set l [lreplace $l $ix $ix]
1451         if {$all} {
1452             while {[set ix [lsearch -exact $l $i]] != -1} {
1453                 set l [lreplace $l $ix $ix]
1454             }
1455         }
1456     }
1457     return $l
1458 }
1459
1460
1461 ## Unknown changed to get output into Console window
1462 # unknown:
1463 # Invoked automatically whenever an unknown command is encountered.
1464 # Works through a list of "unknown handlers" that have been registered
1465 # to deal with unknown commands.  Extensions can integrate their own
1466 # handlers into the "unknown" facility via "unknown_handle".
1467 #
1468 # If a handler exists that recognizes the command, then it will
1469 # take care of the command action and return a valid result or a
1470 # Tcl error.  Otherwise, it should return "-code continue" (=2)
1471 # and responsibility for the command is passed to the next handler.
1472 #
1473 # Arguments:
1474 # args -        A list whose elements are the words of the original
1475 #               command, including the command name.
1476
1477 proc unknown args {
1478     global unknown_handler_order unknown_handlers errorInfo errorCode
1479
1480     #
1481     # Be careful to save error info now, and restore it later
1482     # for each handler.  Some handlers generate their own errors
1483     # and disrupt handling.
1484     #
1485     set savedErrorCode $errorCode
1486     set savedErrorInfo $errorInfo
1487
1488     if {![info exists unknown_handler_order] || \
1489             ![info exists unknown_handlers]} {
1490         set unknown_handlers(tcl) tcl_unknown
1491         set unknown_handler_order tcl
1492     }
1493
1494     foreach handler $unknown_handler_order {
1495         set status [catch {uplevel $unknown_handlers($handler) $args} result]
1496
1497         if {$status == 1} {
1498             #
1499             # Strip the last five lines off the error stack (they're
1500             # from the "uplevel" command).
1501             #
1502             set new [split $errorInfo \n]
1503             set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
1504             return -code $status -errorcode $errorCode \
1505                     -errorinfo $new $result
1506
1507         } elseif {$status != 4} {
1508             return -code $status $result
1509         }
1510
1511         set errorCode $savedErrorCode
1512         set errorInfo $savedErrorInfo
1513     }
1514
1515     set name [lindex $args 0]
1516     return -code error "invalid command name \"$name\""
1517 }
1518
1519 # tcl_unknown:
1520 # Invoked when a Tcl command is invoked that doesn't exist in the
1521 # interpreter:
1522 #
1523 #       1. See if the autoload facility can locate the command in a
1524 #          Tcl script file.  If so, load it and execute it.
1525 #       2. If the command was invoked interactively at top-level:
1526 #           (a) see if the command exists as an executable UNIX program.
1527 #               If so, "exec" the command.
1528 #           (b) see if the command requests csh-like history substitution
1529 #               in one of the common forms !!, !<number>, or ^old^new.  If
1530 #               so, emulate csh's history substitution.
1531 #           (c) see if the command is a unique abbreviation for another
1532 #               command.  If so, invoke the command.
1533 #
1534 # Arguments:
1535 # args -        A list whose elements are the words of the original
1536 #               command, including the command name.
1537
1538 proc tcl_unknown args {
1539     global auto_noexec auto_noload env unknown_pending tcl_interactive Console
1540     global errorCode errorInfo
1541
1542     # Save the values of errorCode and errorInfo variables, since they
1543     # may get modified if caught errors occur below.  The variables will
1544     # be restored just before re-executing the missing command.
1545
1546     set savedErrorCode $errorCode
1547     set savedErrorInfo $errorInfo
1548     set name [lindex $args 0]
1549     if {![info exists auto_noload]} {
1550         #
1551         # Make sure we're not trying to load the same proc twice.
1552         #
1553         if {[info exists unknown_pending($name)]} {
1554             return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
1555         }
1556         set unknown_pending($name) pending;
1557         set ret [catch {auto_load $name} msg]
1558         unset unknown_pending($name);
1559         if {$ret} {
1560             return -code $ret -errorcode $errorCode \
1561                     "error while autoloading \"$name\": $msg"
1562         }
1563         if {![array size unknown_pending]} {
1564             unset unknown_pending
1565         }
1566         if {$msg} {
1567             set errorCode $savedErrorCode
1568             set errorInfo $savedErrorInfo
1569             set code [catch {uplevel 1 $args} msg]
1570             if {$code ==  1} {
1571                 #
1572                 # Strip the last five lines off the error stack (they're
1573                 # from the "uplevel" command).
1574                 #
1575
1576                 set new [split $errorInfo \n]
1577                 set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
1578                 return -code error -errorcode $errorCode \
1579                         -errorinfo $new $msg
1580             } else {
1581                 return -code $code $msg
1582             }
1583         }
1584     }
1585     if {[info level] == 1 && [string match {} [info script]] \
1586             && [info exists tcl_interactive] && $tcl_interactive} {
1587         if {![info exists auto_noexec]} {
1588             set new [auto_execok $name]
1589             if {[string compare $new ""]} {
1590                 set errorCode $savedErrorCode
1591                 set errorInfo $savedErrorInfo
1592                 return [uplevel exec [list $new] [lrange $args 1 end]]
1593                 #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
1594             }
1595         }
1596         set errorCode $savedErrorCode
1597         set errorInfo $savedErrorInfo
1598         ##
1599         ## History substitution moved into ConsoleEvalCmd
1600         ##
1601         set ret [catch {set cmds [info commands $name*]} msg]
1602         if {![string compare $name "::"]} {
1603             set name ""
1604         }
1605         if {$ret != 0} {
1606             return -code $ret -errorcode $errorCode \
1607                 "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
1608         }
1609         if {[llength $cmds] == 1} {
1610             return [uplevel [lreplace $args 0 0 $cmds]]
1611         }
1612         if {[llength $cmds]} {
1613             if {$name == ""} {
1614                 return -code error "empty command name \"\""
1615             } else {
1616                 return -code error \
1617                         "ambiguous command name \"$name\": [lsort $cmds]"
1618             }
1619         }
1620     }
1621     return -code continue
1622 }
1623
1624 switch -glob $tcl_platform(platform) {
1625     win* { set META Alt }
1626     mac* { set META Command }
1627     default { set META Meta }
1628 }
1629
1630 # ConsoleClipboardKeysyms --
1631 # This procedure is invoked to identify the keys that correspond to
1632 # the "copy", "cut", and "paste" functions for the clipboard.
1633 #
1634 # Arguments:
1635 # copy -        Name of the key (keysym name plus modifiers, if any,
1636 #               such as "Meta-y") used for the copy operation.
1637 # cut -         Name of the key used for the cut operation.
1638 # paste -       Name of the key used for the paste operation.
1639
1640 ;proc ConsoleClipboardKeysyms {copy cut paste} {
1641     bind Console <$copy>        {ConsoleCopy %W}
1642     bind Console <$cut>         {ConsoleCut %W}
1643     bind Console <$paste>       {ConsolePaste %W}
1644 }
1645
1646 ;proc ConsoleCut w {
1647     if {[string match $w [selection own -displayof $w]]} {
1648         clipboard clear -displayof $w
1649         catch {
1650             clipboard append -displayof $w [selection get -displayof $w]
1651             if {[$w compare sel.first >= limit]} {$w delete sel.first sel.last}
1652         }
1653     }
1654 }
1655 ;proc ConsoleCopy w {
1656     if {[string match $w [selection own -displayof $w]]} {
1657         clipboard clear -displayof $w
1658         catch {clipboard append -displayof $w [selection get -displayof $w]}
1659     }
1660 }
1661
1662 ;proc ConsolePaste w {
1663     if {
1664         ![catch {selection get -displayof $w} tmp] ||
1665         ![catch {selection get -displayof $w -type TEXT} tmp] ||
1666         ![catch {selection get -displayof $w -selection CLIPBOARD} tmp]
1667     } {
1668         if {[$w compare insert < limit]} {$w mark set insert end}
1669         $w insert insert $tmp
1670         $w see insert
1671         if {[string match *\n* $tmp]} {ConsoleEval $w}
1672     }
1673 }
1674
1675 ## Get all Text bindings into Console
1676 foreach ev [bind Text] { bind Console $ev [bind Text $ev] }
1677 ## We don't want newline insertion
1678 bind Console <Control-Key-o> {}
1679
1680 foreach {ev key} {
1681     <<Console_Previous>>                <Key-Up>
1682     <<Console_Next>>                    <Key-Down>
1683     <<Console_NextImmediate>>           <Control-Key-n>
1684     <<Console_PreviousImmediate>>       <Control-Key-p>
1685     <<Console_PreviousSearch>>          <Control-Key-r>
1686     <<Console_NextSearch>>              <Control-Key-s>
1687
1688     <<Console_Expand>>                  <Key-Tab>
1689     <<Console_ExpandFile>>              <Key-Escape>
1690     <<Console_ExpandProc>>              <Control-Shift-Key-P>
1691     <<Console_ExpandVar>>               <Control-Shift-Key-V>
1692     <<Console_Tab>>                     <Control-Key-i>
1693     <<Console_Tab>>                     <Meta-Key-i>
1694     <<Console_Eval>>                    <Key-Return>
1695     <<Console_Eval>>                    <Key-KP_Enter>
1696
1697     <<Console_Clear>>                   <Control-Key-l>
1698     <<Console_KillLine>>                <Control-Key-k>
1699     <<Console_Transpose>>               <Control-Key-t>
1700     <<Console_ClearLine>>               <Control-Key-u>
1701     <<Console_SaveCommand>>             <Control-Key-z>
1702
1703     <<Console_Exit>>                    <Control-Key-q>
1704     <<Console_New>>                     <Control-Key-N>
1705     <<Console_Close>>                   <Control-Key-w>
1706     <<Console_About>>                   <Control-Key-A>
1707     <<Console_Help>>                    <Control-Key-H>
1708     <<Console_Find>>                    <Control-Key-F>
1709 } {
1710     event add $ev $key
1711     bind Console $key {}
1712 }
1713 catch {unset ev key}
1714
1715 ## Redefine for Console what we need
1716 ##
1717 event delete <<Paste>> <Control-V>
1718 ConsoleClipboardKeysyms <Copy> <Cut> <Paste>
1719
1720 bind Console <Insert> {catch {ConsoleInsert %W [selection get -displayof %W]}}
1721
1722 bind Console <Triple-1> {+
1723 catch {
1724     eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
1725     %W mark set insert sel.first
1726 }
1727 }
1728
1729 bind Console <<Console_Expand>> {
1730     if {[%W compare insert > limit]} {Console:expand %W}
1731     break
1732 }
1733 bind Console <<Console_ExpandFile>> {
1734     if {[%W compare insert > limit]} {Console:expand %W path}
1735     break
1736 }
1737 bind Console <<Console_ExpandProc>> {
1738     if {[%W compare insert > limit]} {Console:expand %W proc}
1739     break
1740 }
1741 bind Console <<Console_ExpandVar>> {
1742     if {[%W compare insert > limit]} {Console:expand %W var}
1743     break
1744 }
1745 bind Console <<Console_Tab>> {
1746     if {[%W compare insert >= limit]} {
1747         ConsoleInsert %W \t
1748     }
1749 }
1750 bind Console <<Console_Eval>> {
1751     ConsoleEval %W
1752 }
1753 bind Console <Delete> {
1754     if {[string compare {} [%W tag nextrange sel 1.0 end]] \
1755             && [%W compare sel.first >= limit]} {
1756         %W delete sel.first sel.last
1757     } elseif {[%W compare insert >= limit]} {
1758         %W delete insert
1759         %W see insert
1760     }
1761 }
1762 bind Console <BackSpace> {
1763     if {[string compare {} [%W tag nextrange sel 1.0 end]] \
1764             && [%W compare sel.first >= limit]} {
1765         %W delete sel.first sel.last
1766     } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
1767         %W delete insert-1c
1768         %W see insert
1769     }
1770 }
1771 bind Console <Control-h> [bind Console <BackSpace>]
1772
1773 bind Console <KeyPress> {
1774     ConsoleInsert %W %A
1775 }
1776
1777 bind Console <Control-a> {
1778     if {[%W compare {limit linestart} == {insert linestart}]} {
1779         tkTextSetCursor %W limit
1780     } else {
1781         tkTextSetCursor %W {insert linestart}
1782     }
1783 }
1784 bind Console <Control-d> {
1785     if {[%W compare insert < limit]} break
1786     %W delete insert
1787 }
1788 bind Console <<Console_KillLine>> {
1789     if {[%W compare insert < limit]} break
1790     if {[%W compare insert == {insert lineend}]} {
1791         %W delete insert
1792     } else {
1793         %W delete insert {insert lineend}
1794     }
1795 }
1796 bind Console <<Console_Clear>> {
1797     Console_clear [winfo parent %W]
1798 }
1799 bind Console <<Console_Previous>> {
1800     if {[%W compare {insert linestart} != {limit linestart}]} {
1801         tkTextSetCursor %W [tkTextUpDownLine %W -1]
1802     } else {
1803         Console_event [winfo parent %W] -1
1804     }
1805 }
1806 bind Console <<Console_Next>> {
1807     if {[%W compare {insert linestart} != {end-1c linestart}]} {
1808         tkTextSetCursor %W [tkTextUpDownLine %W 1]
1809     } else {
1810         Console_event [winfo parent %W] 1
1811     }
1812 }
1813 bind Console <<Console_NextImmediate>> {
1814     Console_event [winfo parent %W] 1
1815 }
1816 bind Console <<Console_PreviousImmediate>> {
1817     Console_event [winfo parent %W] -1
1818 }
1819 bind Console <<Console_PreviousSearch>> {
1820     Console_event [winfo parent %W] -1 [ConsoleCmdGet %W]
1821 }
1822 bind Console <<Console_NextSearch>> {
1823     Console_event [winfo parent %W] 1 [ConsoleCmdGet %W]
1824 }
1825 bind Console <<Console_Transpose>> {
1826     ## Transpose current and previous chars
1827     if {[%W compare insert > limit]} { tkTextTranspose %W }
1828 }
1829 bind Console <<Console_ClearLine>> {
1830     ## Clear command line (Unix shell staple)
1831     %W delete limit end
1832 }
1833 bind Console <<Console_SaveCommand>> {
1834     ## Save command buffer (swaps with current command)
1835     Console:savecommand %W
1836 }
1837 catch {bind Console <Key-Page_Up>   { tkTextScrollPages %W -1 }}
1838 catch {bind Console <Key-Prior>     { tkTextScrollPages %W -1 }}
1839 catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
1840 catch {bind Console <Key-Next>      { tkTextScrollPages %W 1 }}
1841 bind Console <$META-d> {
1842     if {[%W compare insert >= limit]} {
1843         %W delete insert {insert wordend}
1844     }
1845 }
1846 bind Console <$META-BackSpace> {
1847     if {[%W compare {insert -1c wordstart} >= limit]} {
1848         %W delete {insert -1c wordstart} insert
1849     }
1850 }
1851 bind Console <$META-Delete> {
1852     if {[%W compare insert >= limit]} {
1853         %W delete insert {insert wordend}
1854     }
1855 }
1856 bind Console <ButtonRelease-2> {
1857     ## Try and get the default selection, then try and get the selection
1858     ## type TEXT, then try and get the clipboard if nothing else is available
1859     if {
1860         (!$tkPriv(mouseMoved) || $tk_strictMotif) &&
1861         (![catch {selection get -displayof %W} tkPriv(junk)] ||
1862         ![catch {selection get -displayof %W -type TEXT} tkPriv(junk)] ||
1863         ![catch {selection get -displayof %W \
1864                 -selection CLIPBOARD} tkPriv(junk)])
1865     } {
1866         if {[%W compare @%x,%y < limit]} {
1867             %W insert end $tkPriv(junk)
1868         } else {
1869             %W insert @%x,%y $tkPriv(junk)
1870         }
1871         if {[string match *\n* $tkPriv(junk)]} {ConsoleEval %W}
1872     }
1873 }
1874
1875 ##
1876 ## End Console bindings
1877 ##
1878
1879 ##
1880 ## Bindings for doing special things based on certain keys
1881 ##
1882 bind PostConsole <Key-parenright> {
1883     if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchPair %W \( \) limit}
1884 }
1885 bind PostConsole <Key-bracketright> {
1886     if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchPair %W \[ \] limit}
1887 }
1888 bind PostConsole <Key-braceright> {
1889     if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchPair %W \{ \} limit}
1890 }
1891 bind PostConsole <Key-quotedbl> {
1892     if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchQuote %W limit}
1893 }
1894
1895 bind PostConsole <KeyPress> {
1896     if {[string compare {} %A]} { ConsoleTagProc %W }
1897 }
1898
1899
1900 ## ConsoleTagProc - tags a procedure in the console if it's recognized
1901 ## This procedure is not perfect.  However, making it perfect wastes
1902 ## too much CPU time...  Also it should check the existence of a command
1903 ## in whatever is the connected slave, not the master interpreter.
1904 ##
1905 ;proc ConsoleTagProc w {
1906     upvar \#0 [winfo parent $w] data
1907     if {!$data(-lightcmd)} return
1908     set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
1909     set i [$w search -backwards -regexp $exp insert-1c limit-1c]
1910     if {[string compare {} $i]} {append i +2c} {set i limit}
1911     regsub -all {[[\\\?\*]} [$w get $i "insert-1c wordend"] {\\\0} c
1912     if {[string compare {} [ConsoleEvalAttached info commands [list $c]]]} {
1913         $w tag add proc $i "insert-1c wordend"
1914     } else {
1915         $w tag remove proc $i "insert-1c wordend"
1916     }
1917     if {[string compare {} [ConsoleEvalAttached info vars [list $c]]]} {
1918         $w tag add var $i "insert-1c wordend"
1919     } else {
1920         $w tag remove var $i "insert-1c wordend"
1921     }
1922 }
1923
1924 ## ConsoleMatchPair - blinks a matching pair of characters
1925 ## c2 is assumed to be at the text index 'insert'.
1926 ## This proc is really loopy and took me an hour to figure out given
1927 ## all possible combinations with escaping except for escaped \'s.
1928 ## It doesn't take into account possible commenting... Oh well.  If
1929 ## anyone has something better, I'd like to see/use it.  This is really
1930 ## only efficient for small contexts.
1931 # ARGS: w       - console text widget
1932 #       c1      - first char of pair
1933 #       c2      - second char of pair
1934 # Calls:        Console:blink
1935 ##
1936 ;proc ConsoleMatchPair {w c1 c2 {lim 1.0}} {
1937     upvar \#0 [winfo parent $w] data
1938     if {!$data(-lightbrace) || $data(-blinktime)<100} return
1939     if {[string compare [set ix [$w search -back $c1 insert $lim]] {}]} {
1940         while {[string match {\\} [$w get $ix-1c]] && \
1941                 [string compare [set ix [$w search -back $c1 $ix-1c $lim]] {}]} {}
1942         set i1 insert-1c
1943         while {[string compare $ix {}]} {
1944             set i0 $ix
1945             set j 0
1946             while {[string compare [set i0 [$w search $c2 $i0 $i1]] {}]} {
1947                 append i0 +1c
1948                 if {[string match {\\} [$w get $i0-2c]]} continue
1949                 incr j
1950             }
1951             if {!$j} break
1952             set i1 $ix
1953             while {$j && [string compare \
1954                     [set ix [$w search -back $c1 $ix $lim]] {}]} {
1955                 if {[string match {\\} [$w get $ix-1c]]} continue
1956                 incr j -1
1957             }
1958         }
1959         if {[string match {} $ix]} { set ix [$w index $lim] }
1960     } else { set ix [$w index $lim] }
1961     if {$data(-blinkrange)} {
1962         Console:blink $w $data(-blinktime) $ix [$w index insert]
1963     } else {
1964         Console:blink $w $data(-blinktime) $ix $ix+1c \
1965                 [$w index insert-1c] [$w index insert]
1966     }
1967 }
1968
1969 ## ConsoleMatchQuote - blinks between matching quotes.
1970 ## Blinks just the quote if it's unmatched, otherwise blinks quoted string
1971 ## The quote to match is assumed to be at the text index 'insert'.
1972 # ARGS: w       - console text widget
1973 # Calls:        Console:blink
1974 ##
1975 ;proc ConsoleMatchQuote {w {lim 1.0}} {
1976     upvar \#0 [winfo parent $w] data
1977     if {!$data(-lightbrace) || $data(-blinktime)<100} return
1978     set i insert-1c
1979     set j 0
1980     while {[string compare {} [set i [$w search -back \" $i $lim]]]} {
1981         if {[string match {\\} [$w get $i-1c]]} continue
1982         if {!$j} {set i0 $i}
1983         incr j
1984     }
1985     if {[expr $j%2]} {
1986         if {$data(-blinkrange)} {
1987             Console:blink $w $data(-blinktime) $i0 [$w index insert]
1988         } else {
1989             Console:blink $w $data(-blinktime) $i0 $i0+1c \
1990                     [$w index insert-1c] [$w index insert]
1991         }
1992     } else {
1993         Console:blink $w $data(-blinktime) [$w index insert-1c] \
1994                 [$w index insert]
1995     }
1996 }
1997
1998 ## Console:blink - blinks between 2 indices for a specified duration.
1999 # ARGS: w       - console text widget
2000 #       delay   - millisecs to blink for
2001 #       args    - indices of regions to blink
2002 # Outputs:      blinks selected characters in $w
2003 ##
2004 ;proc Console:blink {w delay args} {
2005     eval $w tag add blink $args
2006     after $delay eval $w tag remove blink $args
2007     return
2008 }
2009
2010
2011 ## ConsoleInsert
2012 ## Insert a string into a text console at the point of the insertion cursor.
2013 ## If there is a selection in the text, and it covers the point of the
2014 ## insertion cursor, then delete the selection before inserting.
2015 # ARGS: w       - text window in which to insert the string
2016 #       s       - string to insert (usually just a single char)
2017 # Outputs:      $s to text widget
2018 ##
2019 ;proc ConsoleInsert {w s} {
2020     if {[string match {} $s] || [string match disabled [$w cget -state]]} {
2021         return
2022     }
2023     if {[$w comp insert < limit]} {
2024         $w mark set insert end
2025     }
2026     catch {
2027         if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
2028             $w delete sel.first sel.last
2029         }
2030     }
2031     $w insert insert $s
2032     $w see insert
2033 }
2034
2035 ## Console:expand -
2036 # ARGS: w       - text widget in which to expand str
2037 #       type    - type of expansion (path / proc / variable)
2038 # Calls:        ConsoleExpand(Pathname|Procname|Variable)
2039 # Outputs:      The string to match is expanded to the longest possible match.
2040 #               If data(-showmultiple) is non-zero and the user longest match
2041 #               equaled the string to expand, then all possible matches are
2042 #               output to stdout.  Triggers bell if no matches are found.
2043 # Returns:      number of matches found
2044 ##
2045 ;proc Console:expand {w {type ""}} {
2046     set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
2047     set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
2048     if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit}
2049     if {[$w compare $tmp >= insert]} return
2050     set str [$w get $tmp insert]
2051     switch -glob $type {
2052         pa* { set res [ConsoleExpandPathname $str] }
2053         pr* { set res [ConsoleExpandProcname $str] }
2054         v*  { set res [ConsoleExpandVariable $str] }
2055         default {
2056             set res {}
2057             foreach t {Pathname Procname Variable} {
2058                 if {[string compare {} [set res [ConsoleExpand$t $str]]]} break
2059             }
2060         }
2061     }
2062     set len [llength $res]
2063     if {$len} {
2064         $w delete $tmp insert
2065         $w insert $tmp [lindex $res 0]
2066         if {$len > 1} {
2067             upvar \#0 [winfo parent $w] data
2068             if {$data(-showmultiple) && \
2069                     ![string compare [lindex $res 0] $str]} {
2070                 puts stdout [lreplace $res 0 0]
2071             }
2072         }
2073     } else { bell }
2074     return [incr len -1]
2075 }
2076
2077 ## ConsoleExpandPathname - expand a file pathname based on $str
2078 ## This is based on UNIX file name conventions
2079 # ARGS: str     - partial file pathname to expand
2080 # Calls:        ConsoleExpandBestMatch
2081 # Returns:      list containing longest unique match followed by all the
2082 #               possible further matches
2083 ##
2084 ;proc ConsoleExpandPathname str {
2085     set pwd [ConsoleEvalAttached pwd]
2086     if {[catch {ConsoleEvalAttached [list cd [file dirname $str]]} err]} {
2087         return -code error $err
2088     }
2089     if {[catch {lsort [ConsoleEvalAttached \
2090             [list glob [file tail $str]*]]} m]} {
2091         set match {}
2092     } else {
2093         if {[llength $m] > 1} {
2094             global tcl_platform
2095             if {[string match windows $tcl_platform(platform)]} {
2096                 ## Windows is screwy because it's case insensitive
2097                 set tmp [ConsoleExpandBestMatch [string tolower $m] \
2098                         [string tolower [file tail $str]]]
2099             } else {
2100                 set tmp [ConsoleExpandBestMatch $m [file tail $str]]
2101             }
2102             if {[string match ?*/* $str]} {
2103                 set tmp [file dirname $str]/$tmp
2104             } elseif {[string match /* $str]} {
2105                 set tmp /$tmp
2106             }
2107             regsub -all { } $tmp {\\ } tmp
2108             set match [linsert $m 0 $tmp]
2109         } else {
2110             ## This may look goofy, but it handles spaces in path names
2111             eval append match $m
2112             if {[file isdir $match]} {append match /}
2113             if {[string match ?*/* $str]} {
2114                 set match [file dirname $str]/$match
2115             } elseif {[string match /* $str]} {
2116                 set match /$match
2117             }
2118             regsub -all { } $match {\\ } match
2119             ## Why is this one needed and the ones below aren't!!
2120             set match [list $match]
2121         }
2122     }
2123     ConsoleEvalAttached [list cd $pwd]
2124     return $match
2125 }
2126
2127 ## ConsoleExpandProcname - expand a tcl proc name based on $str
2128 # ARGS: str     - partial proc name to expand
2129 # Calls:        ConsoleExpandBestMatch
2130 # Returns:      list containing longest unique match followed by all the
2131 #               possible further matches
2132 ##
2133 ;proc ConsoleExpandProcname str {
2134     set match [ConsoleEvalAttached [list info commands $str*]]
2135     if {[llength $match] > 1} {
2136         regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str
2137         set match [linsert $match 0 $str]
2138     } else {
2139         regsub -all { } $match {\\ } match
2140     }
2141     return $match
2142 }
2143
2144 ## ConsoleExpandVariable - expand a tcl variable name based on $str
2145 # ARGS: str     - partial tcl var name to expand
2146 # Calls:        ConsoleExpandBestMatch
2147 # Returns:      list containing longest unique match followed by all the
2148 #               possible further matches
2149 ##
2150 ;proc ConsoleExpandVariable str {
2151     if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
2152         ## Looks like they're trying to expand an array.
2153         set match [ConsoleEvalAttached [list array names $ary $str*]]
2154         if {[llength $match] > 1} {
2155             set vars $ary\([ConsoleExpandBestMatch $match $str]
2156             foreach var $match {lappend vars $ary\($var\)}
2157             return $vars
2158         } else {set match $ary\($match\)}
2159         ## Space transformation avoided for array names.
2160     } else {
2161         set match [ConsoleEvalAttached [list info vars $str*]]
2162         if {[llength $match] > 1} {
2163             regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str
2164             set match [linsert $match 0 $str]
2165         } else {
2166             regsub -all { } $match {\\ } match
2167         }
2168     }
2169     return $match
2170 }
2171
2172 ## ConsoleExpandBestMatch2 - finds the best unique match in a list of names
2173 ## Improves upon the speed of the below proc only when $l is small
2174 ## or $e is {}.  $e is extra for compatibility with proc below.
2175 # ARGS: l       - list to find best unique match in
2176 # Returns:      longest unique match in the list
2177 ##
2178 ;proc ConsoleExpandBestMatch2 {l {e {}}} {
2179     set s [lindex $l 0]
2180     if {[llength $l]>1} {
2181         set i [expr [string length $s]-1]
2182         foreach l $l {
2183             while {$i>=0 && [string first $s $l]} {
2184                 set s [string range $s 0 [incr i -1]]
2185             }
2186         }
2187     }
2188     return $s
2189 }
2190
2191 ## ConsoleExpandBestMatch - finds the best unique match in a list of names
2192 ## The extra $e in this argument allows us to limit the innermost loop a
2193 ## little further.  This improves speed as $l becomes large or $e becomes long.
2194 # ARGS: l       - list to find best unique match in
2195 #       e       - currently best known unique match
2196 # Returns:      longest unique match in the list
2197 ##
2198 ;proc ConsoleExpandBestMatch {l {e {}}} {
2199     set ec [lindex $l 0]
2200     if {[llength $l]>1} {
2201         set e  [string length $e]; incr e -1
2202         set ei [string length $ec]; incr ei -1
2203         foreach l $l {
2204             while {$ei>=$e && [string first $ec $l]} {
2205                 set ec [string range $ec 0 [incr ei -1]]
2206             }
2207         }
2208     }
2209     return $ec
2210 }
2211
2212
2213 ## ConsoleResource - re'source's this script into current console
2214 ## Meant primarily for my development of this program.  It follows
2215 ## links until the ultimate source is found.
2216 ##
2217 set Console(SCRIPT) [info script]
2218 if {!$Console(WWW)} {
2219     while {[string match link [file type $Console(SCRIPT)]]} {
2220         set link [file readlink $Console(SCRIPT)]
2221         if {[string match relative [file pathtype $link]]} {
2222             set Console(SCRIPT) [file join \
2223                     [file dirname $Console(SCRIPT)] $link]
2224         } else {
2225             set Console(SCRIPT) $link
2226         }
2227     }
2228     catch {unset link}
2229     if {[string match relative [file pathtype $Console(SCRIPT)]]} {
2230         set Console(SCRIPT) [file join [pwd] $Console(SCRIPT)]
2231     }
2232 }
2233
2234 ;proc Console:resource {} {
2235     global Console
2236     uplevel \#0 [list source $Console(SCRIPT)]
2237 }