util/X86LINUX64/lib/blt2.5/demos/bgexec4.tcl

   1 #!../src/bltwish
   2
   3 package require BLT
   4 # --------------------------------------------------------------------------
   5 # Starting with Tcl 8.x, the BLT commands are stored in their own
   6 # namespace called "blt".  The idea is to prevent name clashes with
   7 # Tcl commands and variables from other packages, such as a "table"
   8 # command in two different packages.
   9 #
  10 # You can access the BLT commands in a couple of ways.  You can prefix
  11 # all the BLT commands with the namespace qualifier "blt::"
  12 #
  13 #    blt::graph .g
  14 #    blt::table . .g -resize both
  15 #
  16 # or you can import all the command into the global namespace.
  17 #
  18 #    namespace import blt::*
  19 #    graph .g
  20 #    table . .g -resize both
  21 #
  22 # --------------------------------------------------------------------------
  23
  24 if { $tcl_version >= 8.0 } {
  25     namespace import blt::*
  26     namespace import -force blt::tile::*
  27 }
  28
  29 source scripts/demo.tcl
  30 source scripts/globe.tcl
  31
  32 option add *HighlightThickness 0
  33
  34 set program [info nameofexecutable]
  35 if { [info exists tcl_platform ] } {
  36     puts stderr $tcl_platform(platform)
  37     if { $tcl_platform(platform) == "windows" } {
  38         set shells [glob C:/Program\ Files/Tcl/bin/tclsh8*.exe ]
  39         set program [lindex $shells 0]
  40     }
  41 }
  42 if { ![file executable $program] } {
  43     error "Can't execute $program"
  44 }
  45
  46 set command [list $program scripts/bgtest.tcl]
  47
  48 array set animate {
  49     index       -1
  50     interval    200
  51     colors      "#ff8813 #ffaa13 #ffcc13 #ffff13 #ffcc13 #ffaa13 #ff8813"
  52     numBitmaps  30
  53     prefix      globe
  54 }
  55
  56 proc Animate {} {
  57     global animate
  58     if { [info commands .logo] != ".logo" } {
  59         set animate(index) 0
  60         return
  61     }
  62     if { $animate(index) >= 0 } {
  63         .logo configure -bitmap $animate(prefix).$animate(index)
  64         incr animate(index)
  65         if { $animate(index) >= $animate(numBitmaps) } {
  66             set animate(index) 0
  67         }
  68         after $animate(interval) Animate
  69     }
  70 }
  71
  72 proc InsertText { string tag } {
  73     .text insert end "$tag: " "" $string $tag
  74     set textlen [expr int([.text index end])]
  75     scan [.vscroll get] "%s %s %s %s" total window first last
  76     if { $textlen > $total } {
  77         .text yview [expr $textlen-$window]
  78     }
  79     update idletasks
  80 }
  81
  82 proc DisplayOutput { name1 name2 how } {
  83     upvar #0 $name1 arr
  84
  85     InsertText "$arr($name2)\n" stdout
  86     set arr($name2) {}
  87 }
  88
  89 proc DisplayErrors { name1 name2 how } {
  90     upvar #0 $name1 arr
  91
  92     InsertText "$arr($name2)\n" stderr
  93     set arr($name2) {}
  94 }
  95
  96
  97 option add *text.yScrollCommand { .vscroll set }
  98 option add *text.relief sunken
  99 option add *text.width 20
 100 option add *text.height 10
 101 option add *text.height 10
 102 option add *text.borderWidth 2
 103 option add *vscroll.command { .text yview }
 104 option add *vscroll.minSlider 4p
 105 option add *stop.command { set results {} }
 106 option add *stop.text { stop }
 107 option add *logo.padX 4
 108 option add *title.text "Catching stdout and stderr"
 109 option add *title.font -*-Helvetica-Bold-R-*-*-14-*-*-*-*-*-*-*
 110
 111 set visual [winfo screenvisual .]
 112 if { [string match *color $visual] } {
 113     option add *text.background white
 114     option add *text.foreground blue
 115     option add *stop.background yellow
 116     option add *stop.activeBackground yellow2
 117     option add *stop.foreground navyblue
 118     option add *start.activeBackground green2
 119     option add *start.background green
 120     option add *start.foreground navyblue
 121     option add *logo.background beige
 122     option add *logo.foreground brown
 123     option add *logo.foreground green4
 124     option add *title.background lightblue
 125     option add *logo.background lightblue
 126 }
 127 . configure -bg lightblue
 128
 129 trace variable results(stdout) w DisplayOutput
 130 trace variable results(stderr) w DisplayErrors
 131
 132 proc Start { command } {
 133     global results animate
 134     .text delete 1.0 end
 135     if { $animate(index) < 0 } {
 136         set results(status) {}
 137         eval "bgexec results(status) -lasterror results(stderr) \
 138                 -lastoutput results(stdout) $command &"
 139         set animate(index) 0
 140         Animate
 141     }
 142 }
 143
 144 proc Stop { } {
 145     global results animate
 146     set results(status) {}
 147     set animate(index) -1
 148 }
 149
 150 # Create widgets
 151 text .text
 152 .text tag configure stdout -font -*-Helvetica-Bold-R-*-*-18-*-*-*-*-*-*-* \
 153     -foreground green2
 154 .text tag configure stderr -font -*-Helvetica-Medium-O-*-*-18-*-*-*-*-*-*-* \
 155     -foreground red2
 156
 157 scrollbar .vscroll
 158 button .start -text "Start" -command [list Start $command]
 159 button .stop -text "Stop" -command Stop
 160 label .logo  -bitmap globe.0
 161 label .title
 162
 163 # Layout widgets in table
 164 table . \
 165     .title      0,0 -columnspan 4 \
 166     .text       1,0 -columnspan 3 \
 167     .vscroll    1,3 -fill y \
 168     .logo       2,0 -anchor w -padx 10 -reqheight .6i -pady 4 \
 169     .start      2,1 \
 170     .stop       2,2
 171
 172 set buttonWidth 1i
 173 table configure . c1 c2 -width 1i
 174 table configure . c3 r0 r2 -resize none
 175 table configure . .start .stop -reqwidth $buttonWidth -anchor e
 176 table configure . .title .text -fill both
 177
 178 wm min . 0 0
 179
 180