HP/util/HP/lib/tk8.0/console.tcl

   1 # console.tcl --
   2 #
   3 # This code constructs the console window for an application.  It
   4 # can be used by non-unix systems that do not have built-in support
   5 # for shells.
   6 #
   7 # SCCS: @(#) console.tcl 1.45 97/09/17 16:52:40
   8 #
   9 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
  10 #
  11 # See the file "license.terms" for information on usage and redistribution
  12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13 #
  14
  15 # TODO: history - remember partially written command
  16
  17 # tkConsoleInit --
  18 # This procedure constructs and configures the console windows.
  19 #
  20 # Arguments:
  21 #       None.
  22
  23 proc tkConsoleInit {} {
  24     global tcl_platform
  25
  26     if {! [consoleinterp eval {set tcl_interactive}]} {
  27         wm withdraw .
  28     }
  29
  30     if {"$tcl_platform(platform)" == "macintosh"} {
  31         set mod "Cmd"
  32     } else {
  33         set mod "Ctrl"
  34     }
  35
  36     menu .menubar
  37     .menubar add cascade -label File -menu .menubar.file -underline 0
  38     .menubar add cascade -label Edit -menu .menubar.edit -underline 0
  39
  40     menu .menubar.file -tearoff 0
  41     .menubar.file add command -label "Source..." -underline 0 \
  42         -command tkConsoleSource
  43     .menubar.file add command -label "Hide Console" -underline 0 \
  44         -command {wm withdraw .}
  45     if {"$tcl_platform(platform)" == "macintosh"} {
  46         .menubar.file add command -label "Quit" -command exit -accel Cmd-Q
  47     } else {
  48         .menubar.file add command -label "Exit" -underline 1 -command exit
  49     }
  50
  51     menu .menubar.edit -tearoff 0
  52     .menubar.edit add command -label "Cut" -underline 2 \
  53         -command { event generate .console <<Cut>> } -accel "$mod+X"
  54     .menubar.edit add command -label "Copy" -underline 0 \
  55         -command { event generate .console <<Copy>> } -accel "$mod+C"
  56     .menubar.edit add command -label "Paste" -underline 1 \
  57         -command { event generate .console <<Paste>> } -accel "$mod+V"
  58
  59     if {"$tcl_platform(platform)" == "windows"} {
  60         .menubar.edit add command -label "Delete" -underline 0 \
  61             -command { event generate .console <<Clear>> } -accel "Del"
  62
  63         .menubar add cascade -label Help -menu .menubar.help -underline 0
  64         menu .menubar.help -tearoff 0
  65         .menubar.help add command -label "About..." -underline 0 \
  66             -command tkConsoleAbout
  67     } else {
  68         .menubar.edit add command -label "Clear" -underline 2 \
  69             -command { event generate .console <<Clear>> }
  70     }
  71
  72     . conf -menu .menubar
  73
  74     text .console  -yscrollcommand ".sb set" -setgrid true
  75     scrollbar .sb -command ".console yview"
  76     pack .sb -side right -fill both
  77     pack .console -fill both -expand 1 -side left
  78     if {$tcl_platform(platform) == "macintosh"} {
  79         .console configure -font {Monaco 9 normal} -highlightthickness 0
  80     }
  81
  82     tkConsoleBind .console
  83
  84     .console tag configure stderr -foreground red
  85     .console tag configure stdin -foreground blue
  86
  87     focus .console
  88
  89     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  90     wm title . "Console"
  91     flush stdout
  92     .console mark set output [.console index "end - 1 char"]
  93     tkTextSetCursor .console end
  94     .console mark set promptEnd insert
  95     .console mark gravity promptEnd left
  96 }
  97
  98 # tkConsoleSource --
  99 #
 100 # Prompts the user for a file to source in the main interpreter.
 101 #
 102 # Arguments:
 103 # None.
 104
 105 proc tkConsoleSource {} {
 106     set filename [tk_getOpenFile -defaultextension .tcl -parent . \
 107                       -title "Select a file to source" \
 108                       -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}]
 109     if {"$filename" != ""} {
 110         set cmd [list source $filename]
 111         if [catch {consoleinterp eval $cmd} result] {
 112             tkConsoleOutput stderr "$result\n"
 113         }
 114     }
 115 }
 116
 117 # tkConsoleInvoke --
 118 # Processes the command line input.  If the command is complete it
 119 # is evaled in the main interpreter.  Otherwise, the continuation
 120 # prompt is added and more input may be added.
 121 #
 122 # Arguments:
 123 # None.
 124
 125 proc tkConsoleInvoke {args} {
 126     set ranges [.console tag ranges input]
 127     set cmd ""
 128     if {$ranges != ""} {
 129         set pos 0
 130         while {[lindex $ranges $pos] != ""} {
 131             set start [lindex $ranges $pos]
 132             set end [lindex $ranges [incr pos]]
 133             append cmd [.console get $start $end]
 134             incr pos
 135         }
 136     }
 137     if {$cmd == ""} {
 138         tkConsolePrompt
 139     } elseif [info complete $cmd] {
 140         .console mark set output end
 141         .console tag delete input
 142         set result [consoleinterp record $cmd]
 143         if {$result != ""} {
 144             .console insert insert "$result\n"
 145         }
 146         tkConsoleHistory reset
 147         tkConsolePrompt
 148     } else {
 149         tkConsolePrompt partial
 150     }
 151     .console yview -pickplace insert
 152 }
 153
 154 # tkConsoleHistory --
 155 # This procedure implements command line history for the
 156 # console.  In general is evals the history command in the
 157 # main interpreter to obtain the history.  The global variable
 158 # histNum is used to store the current location in the history.
 159 #
 160 # Arguments:
 161 # cmd - Which action to take: prev, next, reset.
 162
 163 set histNum 1
 164 proc tkConsoleHistory {cmd} {
 165     global histNum
 166
 167     switch $cmd {
 168         prev {
 169             incr histNum -1
 170             if {$histNum == 0} {
 171                 set cmd {history event [expr [history nextid] -1]}
 172             } else {
 173                 set cmd "history event $histNum"
 174             }
 175             if {[catch {consoleinterp eval $cmd} cmd]} {
 176                 incr histNum
 177                 return
 178             }
 179             .console delete promptEnd end
 180             .console insert promptEnd $cmd {input stdin}
 181         }
 182         next {
 183             incr histNum
 184             if {$histNum == 0} {
 185                 set cmd {history event [expr [history nextid] -1]}
 186             } elseif {$histNum > 0} {
 187                 set cmd ""
 188                 set histNum 1
 189             } else {
 190                 set cmd "history event $histNum"
 191             }
 192             if {$cmd != ""} {
 193                 catch {consoleinterp eval $cmd} cmd
 194             }
 195             .console delete promptEnd end
 196             .console insert promptEnd $cmd {input stdin}
 197         }
 198         reset {
 199             set histNum 1
 200         }
 201     }
 202 }
 203
 204 # tkConsolePrompt --
 205 # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
 206 # exists in the main interpreter it will be called to generate the
 207 # prompt.  Otherwise, a hard coded default prompt is printed.
 208 #
 209 # Arguments:
 210 # partial -     Flag to specify which prompt to print.
 211
 212 proc tkConsolePrompt {{partial normal}} {
 213     if {$partial == "normal"} {
 214         set temp [.console index "end - 1 char"]
 215         .console mark set output end
 216         if [consoleinterp eval "info exists tcl_prompt1"] {
 217             consoleinterp eval "eval \[set tcl_prompt1\]"
 218         } else {
 219             puts -nonewline "% "
 220         }
 221     } else {
 222         set temp [.console index output]
 223         .console mark set output end
 224         if [consoleinterp eval "info exists tcl_prompt2"] {
 225             consoleinterp eval "eval \[set tcl_prompt2\]"
 226         } else {
 227             puts -nonewline "> "
 228         }
 229     }
 230     flush stdout
 231     .console mark set output $temp
 232     tkTextSetCursor .console end
 233     .console mark set promptEnd insert
 234     .console mark gravity promptEnd left
 235 }
 236
 237 # tkConsoleBind --
 238 # This procedure first ensures that the default bindings for the Text
 239 # class have been defined.  Then certain bindings are overridden for
 240 # the class.
 241 #
 242 # Arguments:
 243 # None.
 244
 245 proc tkConsoleBind {win} {
 246     bindtags $win "$win Text . all"
 247
 248     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
 249     # Otherwise, if a widget binding for one of these is defined, the
 250     # <KeyPress> class binding will also fire and insert the character,
 251     # which is wrong.  Ditto for <Escape>.
 252
 253     bind $win <Alt-KeyPress> {# nothing }
 254     bind $win <Meta-KeyPress> {# nothing}
 255     bind $win <Control-KeyPress> {# nothing}
 256     bind $win <Escape> {# nothing}
 257     bind $win <KP_Enter> {# nothing}
 258
 259     bind $win <Tab> {
 260         tkConsoleInsert %W \t
 261         focus %W
 262         break
 263     }
 264     bind $win <Return> {
 265         %W mark set insert {end - 1c}
 266         tkConsoleInsert %W "\n"
 267         tkConsoleInvoke
 268         break
 269     }
 270     bind $win <Delete> {
 271         if {[%W tag nextrange sel 1.0 end] != ""} {
 272             %W tag remove sel sel.first promptEnd
 273         } else {
 274             if [%W compare insert < promptEnd] {
 275                 break
 276             }
 277         }
 278     }
 279     bind $win <BackSpace> {
 280         if {[%W tag nextrange sel 1.0 end] != ""} {
 281             %W tag remove sel sel.first promptEnd
 282         } else {
 283             if [%W compare insert <= promptEnd] {
 284                 break
 285             }
 286         }
 287     }
 288     foreach left {Control-a Home} {
 289         bind $win <$left> {
 290             if [%W compare insert < promptEnd] {
 291                 tkTextSetCursor %W {insert linestart}
 292             } else {
 293                 tkTextSetCursor %W promptEnd
 294             }
 295             break
 296         }
 297     }
 298     foreach right {Control-e End} {
 299         bind $win <$right> {
 300             tkTextSetCursor %W {insert lineend}
 301             break
 302         }
 303     }
 304     bind $win <Control-d> {
 305         if [%W compare insert < promptEnd] {
 306             break
 307         }
 308     }
 309     bind $win <Control-k> {
 310         if [%W compare insert < promptEnd] {
 311             %W mark set insert promptEnd
 312         }
 313     }
 314     bind $win <Control-t> {
 315         if [%W compare insert < promptEnd] {
 316             break
 317         }
 318     }
 319     bind $win <Meta-d> {
 320         if [%W compare insert < promptEnd] {
 321             break
 322         }
 323     }
 324     bind $win <Meta-BackSpace> {
 325         if [%W compare insert <= promptEnd] {
 326             break
 327         }
 328     }
 329     bind $win <Control-h> {
 330         if [%W compare insert <= promptEnd] {
 331             break
 332         }
 333     }
 334     foreach prev {Control-p Up} {
 335         bind $win <$prev> {
 336             tkConsoleHistory prev
 337             break
 338         }
 339     }
 340     foreach prev {Control-n Down} {
 341         bind $win <$prev> {
 342             tkConsoleHistory next
 343             break
 344         }
 345     }
 346     bind $win <Insert> {
 347         catch {tkConsoleInsert %W [selection get -displayof %W]}
 348         break
 349     }
 350     bind $win <KeyPress> {
 351         tkConsoleInsert %W %A
 352         break
 353     }
 354     foreach left {Control-b Left} {
 355         bind $win <$left> {
 356             if [%W compare insert == promptEnd] {
 357                 break
 358             }
 359             tkTextSetCursor %W insert-1c
 360             break
 361         }
 362     }
 363     foreach right {Control-f Right} {
 364         bind $win <$right> {
 365             tkTextSetCursor %W insert+1c
 366             break
 367         }
 368     }
 369     bind $win <F9> {
 370         eval destroy [winfo child .]
 371         if {$tcl_platform(platform) == "macintosh"} {
 372             source -rsrc Console
 373         } else {
 374             source [file join $tk_library console.tcl]
 375         }
 376     }
 377     bind $win <<Cut>> {
 378         # Same as the copy event
 379         if {![catch {set data [%W get sel.first sel.last]}]} {
 380             clipboard clear -displayof %W
 381             clipboard append -displayof %W $data
 382         }
 383         break
 384     }
 385     bind $win <<Copy>> {
 386         if {![catch {set data [%W get sel.first sel.last]}]} {
 387             clipboard clear -displayof %W
 388             clipboard append -displayof %W $data
 389         }
 390         break
 391     }
 392     bind $win <<Paste>> {
 393         catch {
 394             set clip [selection get -displayof %W -selection CLIPBOARD]
 395             set list [split $clip \n\r]
 396             tkConsoleInsert %W [lindex $list 0]
 397             foreach x [lrange $list 1 end] {
 398                 %W mark set insert {end - 1c}
 399                 tkConsoleInsert %W "\n"
 400                 tkConsoleInvoke
 401                 tkConsoleInsert %W $x
 402             }
 403         }
 404         break
 405     }
 406 }
 407
 408 # tkConsoleInsert --
 409 # Insert a string into a text at the point of the insertion cursor.
 410 # If there is a selection in the text, and it covers the point of the
 411 # insertion cursor, then delete the selection before inserting.  Insertion
 412 # is restricted to the prompt area.
 413 #
 414 # Arguments:
 415 # w -           The text window in which to insert the string
 416 # s -           The string to insert (usually just a single character)
 417
 418 proc tkConsoleInsert {w s} {
 419     if {$s == ""} {
 420         return
 421     }
 422     catch {
 423         if {[$w compare sel.first <= insert]
 424                 && [$w compare sel.last >= insert]} {
 425             $w tag remove sel sel.first promptEnd
 426             $w delete sel.first sel.last
 427         }
 428     }
 429     if {[$w compare insert < promptEnd]} {
 430         $w mark set insert end
 431     }
 432     $w insert insert $s {input stdin}
 433     $w see insert
 434 }
 435
 436 # tkConsoleOutput --
 437 #
 438 # This routine is called directly by ConsolePutsCmd to cause a string
 439 # to be displayed in the console.
 440 #
 441 # Arguments:
 442 # dest -        The output tag to be used: either "stderr" or "stdout".
 443 # string -      The string to be displayed.
 444
 445 proc tkConsoleOutput {dest string} {
 446     .console insert output $string $dest
 447     .console see insert
 448 }
 449
 450 # tkConsoleExit --
 451 #
 452 # This routine is called by ConsoleEventProc when the main window of
 453 # the application is destroyed.  Don't call exit - that probably already
 454 # happened.  Just delete our window.
 455 #
 456 # Arguments:
 457 # None.
 458
 459 proc tkConsoleExit {} {
 460     destroy .
 461 }
 462
 463 # tkConsoleAbout --
 464 #
 465 # This routine displays an About box to show Tcl/Tk version info.
 466 #
 467 # Arguments:
 468 # None.
 469
 470 proc tkConsoleAbout {} {
 471     global tk_patchLevel
 472     tk_messageBox -type ok -message "Tcl for Windows
 473 Copyright \251 1996 Sun Microsystems, Inc.
 474
 475 Tcl [info patchlevel]
 476 Tk $tk_patchLevel"
 477 }
 478
 479 # now initialize the console
 480
 481 tkConsoleInit