home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tix8.1 / Console.tcl < prev    next >
Text File  |  2002-01-24  |  16KB  |  613 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: Console.tcl,v 1.2.2.2 2002/01/24 10:08:58 idiscovery Exp $
  4. #
  5. # Console.tcl --
  6. #
  7. #    This code constructs the console window for an application.
  8. #    It can be used by non-unix systems that do not have built-in
  9. #    support for shells.
  10. #
  11. #    This file was distributed as a part of Tk 4.1 by Sun
  12. #    Microsystems, Inc. and subsequently modified by Expert
  13. #    Interface Techonoligies and included as a part of Tix.
  14. #
  15. #    Some of the functions in this file have been renamed from
  16. #    using a "tk" prefix to a "tix" prefix to avoid namespace
  17. #    conflict with the original file.
  18. #
  19. # Copyright (c) 1995-1996 Sun Microsystems, Inc.
  20. # Copyright (c) 1996 Expert Interface Technologies.
  21. #
  22. # See the file "docs/license.tcltk" for information on usage and
  23. # redistribution of the original file "console.tcl". These license
  24. # terms do NOT apply to other files in the Tix distribution.
  25. #
  26. # See the file "license.terms" for information on usage and
  27. # redistribution * of this file, and for a DISCLAIMER OF ALL
  28. # WARRANTIES.
  29.  
  30. # tixConsoleInit --
  31. # This procedure constructs and configures the console windows.
  32. #
  33. # Arguments:
  34. #     None.
  35.  
  36. foreach fun {tkTextSetCursor} {
  37.     if {![llength [info commands $fun]]} {
  38.     tk::unsupported::ExposePrivateCommand $fun
  39.     }
  40. }
  41. unset fun
  42.  
  43. proc tixConsoleInit {} {
  44.     global tcl_platform
  45.  
  46.     uplevel #0 set tixConsoleTextFont Courier
  47.     uplevel #0 set tixConsoleTextSize 14
  48.  
  49.     set f [frame .f]
  50.     set fontcb [tixComboBox $f.size -label "" -command "tixConsoleSetFont" \
  51.     -variable tixConsoleTextFont \
  52.     -options {
  53.         entry.width    15
  54.         listbox.height 5
  55.     }]
  56.     set sizecb [tixComboBox $f.font -label "" -command "tixConsoleSetFont" \
  57.     -variable tixConsoleTextSize \
  58.     -options {
  59.         entry.width    4
  60.         listbox.width  6
  61.         listbox.height 5
  62.     }]
  63.     pack $fontcb $sizecb -side left
  64.     pack $f -side top -fill x -padx 2 -pady 2
  65.     foreach font {
  66.     "Courier New"
  67.     "Courier"
  68.     "Helvetica"
  69.     "Lucida"
  70.     "Lucida Typewriter"
  71.     "MS LineDraw"
  72.     "System"
  73.     "Times Roman"
  74.     } {
  75.     $fontcb subwidget listbox insert end $font
  76.     }
  77.  
  78.     for {set s 6} {$s < 25} {incr s} {
  79.     $sizecb subwidget listbox insert end $s
  80.     }
  81.  
  82.     bind [$fontcb subwidget entry] <Escape> "focus .console"
  83.     bind [$sizecb subwidget entry] <Escape> "focus .console"
  84.  
  85.     text .console  -yscrollcommand ".sb set" -setgrid true \
  86.     -highlightcolor [. cget -bg] -highlightbackground [. cget -bg] \
  87.     -cursor left_ptr
  88.     scrollbar .sb -command ".console yview" -highlightcolor [. cget -bg] \
  89.     -highlightbackground [. cget -bg]
  90.     pack .sb -side right -fill both
  91.     pack .console -fill both -expand 1 -side left
  92.  
  93.     tixConsoleBind .console
  94.  
  95.     .console tag configure stderr -foreground red
  96.     .console tag configure stdin -foreground blue
  97.  
  98.     focus .console
  99.     
  100.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  101.     wm title . "Console"
  102.     flush stdout
  103.     .console mark set output [.console index "end - 1 char"]
  104.     tkTextSetCursor .console end
  105.     .console mark set promptEnd insert
  106.     .console mark gravity promptEnd left
  107.  
  108.     tixConsoleSetFont
  109. }
  110.  
  111. proc tixConsoleSetFont {args} {
  112.     if ![winfo exists .console] tixConsoleInit
  113.  
  114.     global tixConsoleTextFont tixConsoleTextSize
  115.  
  116.     set font  -*-$tixConsoleTextFont-medium-r-normal-*-$tixConsoleTextSize-*-*-*-*-*-*-*
  117.     .console config -font $font
  118. }
  119.  
  120. # tixConsoleInvoke --
  121. # Processes the command line input.  If the command is complete it
  122. # is evaled in the main interpreter.  Otherwise, the continuation
  123. # prompt is added and more input may be added.
  124. #
  125. # Arguments:
  126. # None.
  127.  
  128. proc tixConsoleInvoke {args} {
  129.     if ![winfo exists .console] tixConsoleInit
  130.  
  131.     if {[.console dlineinfo insert] != {}} {
  132.     set setend 1
  133.     } else {
  134.     set setend 0
  135.     }
  136.     set ranges [.console tag ranges input]
  137.     set cmd ""
  138.     if {$ranges != ""} {
  139.     set pos 0
  140.     while {[lindex $ranges $pos] != ""} {
  141.         set start [lindex $ranges $pos]
  142.         set end [lindex $ranges [incr pos]]
  143.         append cmd [.console get $start $end]
  144.         incr pos
  145.     }
  146.     }
  147.     if {$cmd == ""} {
  148.     tixConsolePrompt
  149.     } elseif {[info complete $cmd]} {
  150.     .console mark set output end
  151.     .console tag delete input
  152.     set err [catch {
  153.         set result [interp record $cmd]
  154.     } result]
  155.  
  156.     if {$result != ""} {
  157.         if {$err} {
  158.         .console insert insert "$result\n" stderr
  159.         } else {
  160.         .console insert insert "$result\n"
  161.         }
  162.     }
  163.     tixConsoleHistory reset
  164.     tixConsolePrompt
  165.     } else {
  166.     tixConsolePrompt partial
  167.     }
  168.     if {$setend} {
  169.     .console yview -pickplace insert
  170.     }
  171. }
  172.  
  173. # tixConsoleHistory --
  174. # This procedure implements command line history for the
  175. # console.  In general is evals the history command in the
  176. # main interpreter to obtain the history.  The global variable
  177. # histNum is used to store the current location in the history.
  178. #
  179. # Arguments:
  180. # cmd -    Which action to take: prev, next, reset.
  181.  
  182. set histNum 1
  183. proc tixConsoleHistory {cmd} {
  184.     if ![winfo exists .console] tixConsoleInit
  185.  
  186.     global histNum
  187.     
  188.     switch $cmd {
  189.         prev {
  190.         incr histNum -1
  191.         if {$histNum == 0} {
  192.         set cmd {history event [expr [history nextid] -1]}
  193.         } else {
  194.         set cmd "history event $histNum"
  195.         }
  196.             if {[catch {interp eval $cmd} cmd]} {
  197.                 incr histNum
  198.                 return
  199.             }
  200.         .console delete promptEnd end
  201.             .console insert promptEnd $cmd {input stdin}
  202.         }
  203.         next {
  204.         incr histNum
  205.         if {$histNum == 0} {
  206.         set cmd {history event [expr [history nextid] -1]}
  207.         } elseif {$histNum > 0} {
  208.         set cmd ""
  209.         set histNum 1
  210.         } else {
  211.         set cmd "history event $histNum"
  212.         }
  213.         if {$cmd != ""} {
  214.         catch {interp eval $cmd} cmd
  215.         }
  216.         .console delete promptEnd end
  217.         .console insert promptEnd $cmd {input stdin}
  218.         }
  219.         reset {
  220.             set histNum 1
  221.         }
  222.     }
  223. }
  224.  
  225. # tixConsolePrompt --
  226. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  227. # exists in the main interpreter it will be called to generate the 
  228. # prompt.  Otherwise, a hard coded default prompt is printed.
  229. #
  230. # Arguments:
  231. # partial -    Flag to specify which prompt to print.
  232.  
  233. proc tixConsolePrompt {{partial normal}} {
  234.     if ![winfo exists .console] tixConsoleInit
  235.  
  236.     if {$partial == "normal"} {
  237.     set temp [.console index "end - 1 char"]
  238.     .console mark set output end
  239.         if {[interp eval "info exists tcl_prompt1"]} {
  240.             interp eval "eval \[set tcl_prompt1\]"
  241.         } else {
  242.             puts -nonewline "% "
  243.         }
  244.     } else {
  245.     set temp [.console index output]
  246.     .console mark set output end
  247.         if {[interp eval "info exists tcl_prompt2"]} {
  248.             interp eval "eval \[set tcl_prompt2\]"
  249.         } else {
  250.         puts -nonewline "> "
  251.         }
  252.     }
  253.  
  254.     flush stdout
  255.     .console mark set output $temp
  256.     tkTextSetCursor .console end
  257.     .console mark set promptEnd insert
  258.     .console mark gravity promptEnd left
  259. }
  260.  
  261. # tixConsoleBind --
  262. # This procedure first ensures that the default bindings for the Text
  263. # class have been defined.  Then certain bindings are overridden for
  264. # the class.
  265. #
  266. # Arguments:
  267. # None.
  268.  
  269. proc tixConsoleBind {win} {
  270.     if ![winfo exists .console] tixConsoleInit
  271.  
  272.     bindtags $win "$win Text . all"
  273.  
  274.     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  275.     # Otherwise, if a widget binding for one of these is defined, the
  276.     # <KeyPress> class binding will also fire and insert the character,
  277.     # which is wrong.  Ditto for <Escape>.
  278.  
  279.     bind $win <Alt-KeyPress> {# nothing }
  280.     bind $win <Meta-KeyPress> {# nothing}
  281.     bind $win <Control-KeyPress> {# nothing}
  282.     bind $win <Escape> {# nothing}
  283.     bind $win <KP_Enter> {# nothing}
  284.  
  285.     bind $win <Tab> {
  286.     tixConsoleInsert %W \t
  287.     focus %W
  288.     break
  289.     }
  290.     bind $win <Return> {
  291.     %W mark set insert {end - 1c}
  292.     tixConsoleInsert %W "\n"
  293.     tixConsoleInvoke
  294.     break
  295.     }
  296.     bind $win <Delete> {
  297.     if {[%W tag nextrange sel 1.0 end] != ""} {
  298.         %W tag remove sel sel.first promptEnd
  299.     } else {
  300.         if {[%W compare insert < promptEnd]} {
  301.         break
  302.         }
  303.     }
  304.     }
  305.     bind $win <BackSpace> {
  306.     if {[%W tag nextrange sel 1.0 end] != ""} {
  307.         %W tag remove sel sel.first promptEnd
  308.     } else {
  309.         if {[%W compare insert <= promptEnd]} {
  310.         break
  311.         }
  312.     }
  313.     }
  314.     foreach left {Control-a Home} {
  315.     bind $win <$left> {
  316.         if {[%W compare insert < promptEnd]} {
  317.         tkTextSetCursor %W {insert linestart}
  318.         } else {
  319.         tkTextSetCursor %W promptEnd
  320.             }
  321.         break
  322.     }
  323.     }
  324.     foreach right {Control-e End} {
  325.     bind $win <$right> {
  326.         tkTextSetCursor %W {insert lineend}
  327.         break
  328.     }
  329.     }
  330.     bind $win <Control-d> {
  331.     if {[%W compare insert < promptEnd]} {
  332.         break
  333.     }
  334.     }
  335.     bind $win <Control-k> {
  336.     if {[%W compare insert < promptEnd]} {
  337.         %W mark set insert promptEnd
  338.     }
  339.     }
  340.     bind $win <Control-t> {
  341.     if {[%W compare insert < promptEnd]} {
  342.         break
  343.     }
  344.     }
  345.     bind $win <Meta-d> {
  346.     if {[%W compare insert < promptEnd]} {
  347.         break
  348.     }
  349.     }
  350.     bind $win <Meta-BackSpace> {
  351.     if {[%W compare insert <= promptEnd]} {
  352.         break
  353.     }
  354.     }
  355.     bind $win <Control-h> {
  356.     if {[%W compare insert <= promptEnd]} {
  357.         break
  358.     }
  359.     }
  360.     foreach prev {Control-p Up} {
  361.     bind $win <$prev> {
  362.         tixConsoleHistory prev
  363.         break
  364.     }
  365.     }
  366.     foreach prev {Control-n Down} {
  367.     bind $win <$prev> {
  368.         tixConsoleHistory next
  369.         break
  370.     }
  371.     }
  372.     bind $win <Control-v> {
  373.     if {[%W compare insert > promptEnd]} {
  374.         catch {
  375.         %W insert insert [selection get -displayof %W] {input stdin}
  376.         %W see insert
  377.         }
  378.     }
  379.     break
  380.     }
  381.     bind $win <Insert> {
  382.     catch {tixConsoleInsert %W [selection get -displayof %W]}
  383.     break
  384.     }
  385.     bind $win <KeyPress> {
  386.     tixConsoleInsert %W %A
  387.     break
  388.     }
  389.     foreach left {Control-b Left} {
  390.     bind $win <$left> {
  391.         if {[%W compare insert == promptEnd]} {
  392.         break
  393.         }
  394.         tkTextSetCursor %W insert-1c
  395.         break
  396.     }
  397.     }
  398.     foreach right {Control-f Right} {
  399.     bind $win <$right> {
  400.         tkTextSetCursor %W insert+1c
  401.         break
  402.     }
  403.     }
  404.     bind $win <Control-Up> {
  405.     %W yview scroll -1 unit
  406.     break;
  407.     }
  408.     bind $win <Control-Down> {
  409.     %W yview scroll 1 unit
  410.     break;
  411.     }
  412.     bind $win <Prior> {
  413.     %W yview scroll -1 pages
  414.     }
  415.     bind $win <Next> {
  416.     %W yview scroll  1 pages
  417.     }
  418.     bind $win <F9> {
  419.     eval destroy [winfo child .]
  420.     source $tix_library/Console.tcl
  421.     }
  422.     foreach copy {F16 Meta-w Control-i} {
  423.     bind $win <$copy> {
  424.         if {[selection own -displayof %W] == "%W"} {
  425.         clipboard clear -displayof %W
  426.         catch {
  427.             clipboard append -displayof %W [selection get -displayof %W]
  428.         }
  429.         }
  430.         break
  431.     }
  432.     }
  433.     foreach paste {F18 Control-y} {
  434.     bind $win <$paste> {
  435.         catch {
  436.             set clip [selection get -displayof %W -selection CLIPBOARD]
  437.         set list [split $clip \n\r]
  438.         tixConsoleInsert %W [lindex $list 0]
  439.         foreach x [lrange $list 1 end] {
  440.             %W mark set insert {end - 1c}
  441.             tixConsoleInsert %W "\n"
  442.             tixConsoleInvoke
  443.             tixConsoleInsert %W $x
  444.         }
  445.         }
  446.         break
  447.     }
  448.     }
  449. }
  450.  
  451. # tixConsoleInsert --
  452. # Insert a string into a text at the point of the insertion cursor.
  453. # If there is a selection in the text, and it covers the point of the
  454. # insertion cursor, then delete the selection before inserting.  Insertion
  455. # is restricted to the prompt area.
  456. #
  457. # Arguments:
  458. # w -        The text window in which to insert the string
  459. # s -        The string to insert (usually just a single character)
  460.  
  461. proc tixConsoleInsert {w s} {
  462.     if ![winfo exists .console] tixConsoleInit
  463.  
  464.     if {[.console dlineinfo insert] != {}} {
  465.     set setend 1
  466.     } else {
  467.     set setend 0
  468.     }
  469.     if {$s == ""} {
  470.     return
  471.     }
  472.     catch {
  473.     if {[$w compare sel.first <= insert]
  474.         && [$w compare sel.last >= insert]} {
  475.         $w tag remove sel sel.first promptEnd
  476.         $w delete sel.first sel.last
  477.     }
  478.     }
  479.     if {[$w compare insert < promptEnd]} {
  480.     $w mark set insert end    
  481.     }
  482.     $w insert insert $s {input stdin}
  483.     if $setend {
  484.     .console see insert
  485.     }
  486. }
  487.  
  488.  
  489.  
  490. # tixConsoleOutput --
  491. #
  492. # This routine is called directly by ConsolePutsCmd to cause a string
  493. # to be displayed in the console.
  494. #
  495. # Arguments:
  496. # dest -    The output tag to be used: either "stderr" or "stdout".
  497. # string -    The string to be displayed.
  498.  
  499. proc tixConsoleOutput {dest string} {
  500.     if ![winfo exists .console] tixConsoleInit
  501.  
  502.     if {[.console dlineinfo insert] != {}} {
  503.     set setend 1
  504.     } else {
  505.     set setend 0
  506.     }
  507.     .console insert output $string $dest
  508.     if $setend {
  509.     .console see insert
  510.     }
  511. }
  512.  
  513. # tixConsoleExit --
  514. #
  515. # This routine is called by ConsoleEventProc when the main window of
  516. # the application is destroyed.
  517. #
  518. # Arguments:
  519. # None.
  520.  
  521. proc tixConsoleExit {} {
  522.     if ![winfo exists .console] tixConsoleInit
  523.  
  524.     exit
  525. }
  526.  
  527. # Configure the default Tk console
  528. proc tixConsoleEvalAppend {inter} {
  529.     global tixOption
  530.     # A slave like the console interp has no global variables set!
  531.     
  532.     if {!$inter} {
  533.     console hide
  534.  
  535.     # Change the menubar to Close the console instead of exiting
  536.     # Your code must provide a way for the user to do a "console show"
  537.     console eval {
  538.         if {[winfo exists .menubar.file]} {
  539.         .menubar.file entryconfigure "Hide Console" \
  540.             -underline 0 \
  541.             -label Close \
  542.             -command [list wm withdraw .]
  543.         .menubar.file entryconfigure Exit -state disabled
  544.         }
  545.     }
  546.     }
  547.  
  548.     console eval ".option configure -font \{$tixOption(fixed_font)\}"
  549.  
  550.     console eval {
  551.     if {[winfo exists .menubar.edit]} {
  552.         .menubar.edit add sep
  553.         .menubar.edit add command \
  554.             -accelerator 'Ctrl+l' \
  555.             -underline 0 \
  556.             -label Clear \
  557.             -command [list .console delete 1.0 end]
  558.         bind .console <Control-Key-l> [list .console delete 1.0 end]
  559.     }
  560.     if {![winfo exists .menubar.font]} {
  561.         set m .menubar.font
  562.         menu $m -tearoff 0
  563.         .menubar add cascade -menu .menubar.font \
  564.             -underline 0 -label Options
  565.  
  566.         global _TixConsole
  567.         set font [font actual [.console cget -font]]
  568.         set pos [lsearch $font -family]
  569.         set _TixConsole(font) [lindex $font [incr pos]]
  570.         set pos [lsearch $font -size]
  571.         set _TixConsole(size) [lindex $font [incr pos]]
  572.         set pos [lsearch $font -weight]
  573.         set _TixConsole(weight) [lindex $font [incr pos]]
  574.  
  575.         set allowed {System Fixedsys Terminal {MS Serif} 
  576.         {MS Sans Serif} Courier {Lucida Console} Tahoma 
  577.         Arial {Courier New} {Times New Roman} 
  578.         {Arial Black} Verdana  Garamond  {Arial Narrow}}
  579.         .menubar.font add cascade -label Font -menu $m.font
  580.         menu $m.font -tearoff 0
  581.         foreach font [lsort [font families]] {
  582.         if {[lsearch $allowed $font] < 0} {continue}
  583.         $m.font add radiobutton -label $font \
  584.             -variable _TixConsole(font) \
  585.             -value $font \
  586.             -command \
  587.             ".console configure -font \"\{$font\} \$_TixConsole(size) \$_TixConsole(weight)\""
  588.         }
  589.  
  590.         .menubar.font add cascade -label Size -menu $m.size
  591.         menu $m.size -tearoff 0
  592.         foreach size {8 9 10 12 14 16 18} {
  593.         $m.size add radiobutton -label $size \
  594.             -variable _TixConsole(size) \
  595.             -value $size \
  596.             -command \
  597.             ".console configure -font \"\{\$_TixConsole(font)\} $size \$_TixConsole(weight)\""
  598.         }
  599.  
  600.         .menubar.font add cascade -label Weight -menu $m.weight
  601.         menu $m.weight -tearoff 0
  602.         foreach weight {normal bold} {
  603.         $m.weight add radiobutton -label [string totit $weight] \
  604.             -variable _TixConsole(weight) \
  605.             -value $weight \
  606.             -command \
  607.             ".console configure -font \"\{\$_TixConsole(font)\} \$_TixConsole(size) $weight\""
  608.         }
  609.  
  610.     }
  611.     }
  612. }
  613.