Go to most recent revision | Details | Last modification | View Log | RSS feed
| Rev | Author | Line No. | Line |
|---|---|---|---|
| 2 | mjames | 1 | # A Notebook widget for Tcl/Tk |
| 2 | # $Revision: 1.1.1.1 $ |
||
| 3 | # |
||
| 4 | # Copyright (C) 1996,1997,1998 D. Richard Hipp |
||
| 5 | # |
||
| 6 | # This library is free software; you can redistribute it and/or |
||
| 7 | # modify it under the terms of the GNU Library General Public |
||
| 8 | # License as published by the Free Software Foundation; either |
||
| 9 | # version 2 of the License, or (at your option) any later version. |
||
| 10 | # |
||
| 11 | # This library is distributed in the hope that it will be useful, |
||
| 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
||
| 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
||
| 14 | # Library General Public License for more details. |
||
| 15 | # |
||
| 16 | # You should have received a copy of the GNU Library General Public |
||
| 17 | # License along with this library; if not, write to the |
||
| 18 | # Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
||
| 19 | # Boston, MA 02111-1307, USA. |
||
| 20 | # |
||
| 21 | # Author contact information: |
||
| 22 | # drh@acm.org |
||
| 23 | # http://www.hwaci.com/drh/ |
||
| 24 | |||
| 25 | # |
||
| 26 | # Create a new notebook widget |
||
| 27 | # |
||
| 28 | proc Notebook:create {w args} { |
||
| 29 | global Notebook |
||
| 30 | set Notebook($w,width) 400 |
||
| 31 | set Notebook($w,height) 300 |
||
| 32 | set Notebook($w,pages) {} |
||
| 33 | set Notebook($w,top) 0 |
||
| 34 | set Notebook($w,pad) 5 |
||
| 35 | set Notebook($w,fg,on) black |
||
| 36 | set Notebook($w,fg,off) grey50 |
||
| 37 | canvas $w -bd 0 -highlightthickness 0 -takefocus 0 |
||
| 38 | set Notebook($w,bg) [$w cget -bg] |
||
| 39 | bind $w <1> "Notebook:click $w %x %y" |
||
| 40 | bind $w <Configure> "Notebook:scheduleExpand $w" |
||
| 41 | eval Notebook:config $w $args |
||
| 42 | } |
||
| 43 | |||
| 44 | # |
||
| 45 | # Change configuration options for the notebook widget |
||
| 46 | # |
||
| 47 | proc Notebook:config {w args} { |
||
| 48 | global Notebook |
||
| 49 | foreach {tag value} $args { |
||
| 50 | switch -- $tag { |
||
| 51 | -width { |
||
| 52 | set Notebook($w,width) $value |
||
| 53 | } |
||
| 54 | -height { |
||
| 55 | set Notebook($w,height) $value |
||
| 56 | } |
||
| 57 | -pages { |
||
| 58 | set Notebook($w,pages) $value |
||
| 59 | } |
||
| 60 | -pad { |
||
| 61 | set Notebook($w,pad) $value |
||
| 62 | } |
||
| 63 | -bg { |
||
| 64 | set Notebook($w,bg) $value |
||
| 65 | } |
||
| 66 | -fg { |
||
| 67 | set Notebook($w,fg,on) $value |
||
| 68 | } |
||
| 69 | -disabledforeground { |
||
| 70 | set Notebook($w,fg,off) $value |
||
| 71 | } |
||
| 72 | } |
||
| 73 | } |
||
| 74 | |||
| 75 | # |
||
| 76 | # After getting new configuration values, reconstruct the widget |
||
| 77 | # |
||
| 78 | $w delete all |
||
| 79 | set Notebook($w,x1) $Notebook($w,pad) |
||
| 80 | set Notebook($w,x2) [expr $Notebook($w,x1)+2] |
||
| 81 | set Notebook($w,x3) [expr $Notebook($w,x2)+$Notebook($w,width)] |
||
| 82 | set Notebook($w,x4) [expr $Notebook($w,x3)+2] |
||
| 83 | set Notebook($w,y1) [expr $Notebook($w,pad)+2] |
||
| 84 | set Notebook($w,y2) [expr $Notebook($w,y1)+2] |
||
| 85 | set Notebook($w,y5) [expr $Notebook($w,y1)+30] |
||
| 86 | set Notebook($w,y6) [expr $Notebook($w,y5)+2] |
||
| 87 | set Notebook($w,y3) [expr $Notebook($w,y6)+$Notebook($w,height)] |
||
| 88 | set Notebook($w,y4) [expr $Notebook($w,y3)+2] |
||
| 89 | set x $Notebook($w,x1) |
||
| 90 | set cnt 0 |
||
| 91 | set y7 [expr $Notebook($w,y1)+10] |
||
| 92 | label $w.dummy -text hi |
||
| 93 | set font [$w.dummy cget -font] |
||
| 94 | destroy $w.dummy |
||
| 95 | foreach p $Notebook($w,pages) { |
||
| 96 | set Notebook($w,p$cnt,x5) $x |
||
| 97 | set id [$w create text 0 0 -text $p -anchor nw \ |
||
| 98 | -font $font -tags "p$cnt t$cnt"] |
||
| 99 | set bbox [$w bbox $id] |
||
| 100 | set width [lindex $bbox 2] |
||
| 101 | $w move $id [expr $x+10] $y7 |
||
| 102 | $w create line \ |
||
| 103 | $x $Notebook($w,y5)\ |
||
| 104 | $x $Notebook($w,y2) \ |
||
| 105 | [expr $x+2] $Notebook($w,y1) \ |
||
| 106 | [expr $x+$width+16] $Notebook($w,y1) \ |
||
| 107 | -width 2 -fill white -tags p$cnt |
||
| 108 | $w create line \ |
||
| 109 | [expr $x+$width+16] $Notebook($w,y1) \ |
||
| 110 | [expr $x+$width+18] $Notebook($w,y2) \ |
||
| 111 | [expr $x+$width+18] $Notebook($w,y5) \ |
||
| 112 | -width 2 -fill black -tags p$cnt |
||
| 113 | set x [expr $x+$width+20] |
||
| 114 | set Notebook($w,p$cnt,x6) [expr $x-2] |
||
| 115 | if {![winfo exists $w.f$cnt]} { |
||
| 116 | frame $w.f$cnt -bd 0 |
||
| 117 | } |
||
| 118 | $w.f$cnt config -bg $Notebook($w,bg) |
||
| 119 | place $w.f$cnt -x $Notebook($w,x2) -y $Notebook($w,y6) \ |
||
| 120 | -width $Notebook($w,width) -height $Notebook($w,height) |
||
| 121 | incr cnt |
||
| 122 | } |
||
| 123 | $w create line \ |
||
| 124 | $Notebook($w,x1) [expr $Notebook($w,y5)-2] \ |
||
| 125 | $Notebook($w,x1) $Notebook($w,y3) \ |
||
| 126 | -width 2 -fill white |
||
| 127 | $w create line \ |
||
| 128 | $Notebook($w,x1) $Notebook($w,y3) \ |
||
| 129 | $Notebook($w,x2) $Notebook($w,y4) \ |
||
| 130 | $Notebook($w,x3) $Notebook($w,y4) \ |
||
| 131 | $Notebook($w,x4) $Notebook($w,y3) \ |
||
| 132 | $Notebook($w,x4) $Notebook($w,y6) \ |
||
| 133 | $Notebook($w,x3) $Notebook($w,y5) \ |
||
| 134 | -width 2 -fill black |
||
| 135 | $w config -width [expr $Notebook($w,x4)+$Notebook($w,pad)] \ |
||
| 136 | -height [expr $Notebook($w,y4)+$Notebook($w,pad)] \ |
||
| 137 | -bg $Notebook($w,bg) |
||
| 138 | set top $Notebook($w,top) |
||
| 139 | set Notebook($w,top) -1 |
||
| 140 | Notebook:raise.page $w $top |
||
| 141 | } |
||
| 142 | |||
| 143 | # |
||
| 144 | # This routine is called whenever the mouse-button is pressed over |
||
| 145 | # the notebook. It determines if any page should be raised and raises |
||
| 146 | # that page. |
||
| 147 | # |
||
| 148 | proc Notebook:click {w x y} { |
||
| 149 | global Notebook |
||
| 150 | if {$y<$Notebook($w,y1) || $y>$Notebook($w,y6)} return |
||
| 151 | set N [llength $Notebook($w,pages)] |
||
| 152 | for {set i 0} {$i<$N} {incr i} { |
||
| 153 | if {$x>=$Notebook($w,p$i,x5) && $x<=$Notebook($w,p$i,x6)} { |
||
| 154 | Notebook:raise.page $w $i |
||
| 155 | break |
||
| 156 | } |
||
| 157 | } |
||
| 158 | } |
||
| 159 | |||
| 160 | # |
||
| 161 | # For internal use only. This procedure raised the n-th page of |
||
| 162 | # the notebook |
||
| 163 | # |
||
| 164 | proc Notebook:raise.page {w n} { |
||
| 165 | global Notebook |
||
| 166 | if {$n<0 || $n>=[llength $Notebook($w,pages)]} return |
||
| 167 | set top $Notebook($w,top) |
||
| 168 | if {$top>=0 && $top<[llength $Notebook($w,pages)]} { |
||
| 169 | $w move p$top 0 2 |
||
| 170 | } |
||
| 171 | $w move p$n 0 -2 |
||
| 172 | $w delete topline |
||
| 173 | if {$n>0} { |
||
| 174 | $w create line \ |
||
| 175 | $Notebook($w,x1) $Notebook($w,y6) \ |
||
| 176 | $Notebook($w,x2) $Notebook($w,y5) \ |
||
| 177 | $Notebook($w,p$n,x5) $Notebook($w,y5) \ |
||
| 178 | $Notebook($w,p$n,x5) [expr $Notebook($w,y5)-2] \ |
||
| 179 | -width 2 -fill white -tags topline |
||
| 180 | } |
||
| 181 | $w create line \ |
||
| 182 | $Notebook($w,p$n,x6) [expr $Notebook($w,y5)-2] \ |
||
| 183 | $Notebook($w,p$n,x6) $Notebook($w,y5) \ |
||
| 184 | -width 2 -fill white -tags topline |
||
| 185 | $w create line \ |
||
| 186 | $Notebook($w,p$n,x6) $Notebook($w,y5) \ |
||
| 187 | $Notebook($w,x3) $Notebook($w,y5) \ |
||
| 188 | -width 2 -fill white -tags topline |
||
| 189 | set Notebook($w,top) $n |
||
| 190 | raise $w.f$n |
||
| 191 | } |
||
| 192 | |||
| 193 | # |
||
| 194 | # Change the page-specific configuration options for the notebook |
||
| 195 | # |
||
| 196 | proc Notebook:pageconfig {w name args} { |
||
| 197 | global Notebook |
||
| 198 | set i [lsearch $Notebook($w,pages) $name] |
||
| 199 | if {$i<0} return |
||
| 200 | foreach {tag value} $args { |
||
| 201 | switch -- $tag { |
||
| 202 | -state { |
||
| 203 | if {"$value"=="disabled"} { |
||
| 204 | $w itemconfig t$i -fg $Notebook($w,fg,off) |
||
| 205 | } else { |
||
| 206 | $w itemconfig t$i -fg $Notebook($w,fg,on) |
||
| 207 | } |
||
| 208 | } |
||
| 209 | -onexit { |
||
| 210 | set Notebook($w,p$i,onexit) $value |
||
| 211 | } |
||
| 212 | } |
||
| 213 | } |
||
| 214 | } |
||
| 215 | |||
| 216 | # |
||
| 217 | # This procedure raises a notebook page given its name. But first |
||
| 218 | # we check the "onexit" procedure for the current page (if any) and |
||
| 219 | # if it returns false, we don't allow the raise to proceed. |
||
| 220 | # |
||
| 221 | proc Notebook:raise {w name} { |
||
| 222 | global Notebook |
||
| 223 | set i [lsearch $Notebook($w,pages) $name] |
||
| 224 | if {$i<0} return |
||
| 225 | if {[info exists Notebook($w,p$i,onexit)]} { |
||
| 226 | set onexit $Notebook($w,p$i,onexit) |
||
| 227 | if {"$onexit"!="" && [eval uplevel #0 $onexit]!=0} { |
||
| 228 | Notebook:raise.page $w $i |
||
| 229 | } |
||
| 230 | } else { |
||
| 231 | Notebook:raise.page $w $i |
||
| 232 | } |
||
| 233 | } |
||
| 234 | |||
| 235 | # |
||
| 236 | # Return the frame associated with a given page of the notebook. |
||
| 237 | # |
||
| 238 | proc Notebook:frame {w name} { |
||
| 239 | global Notebook |
||
| 240 | set i [lsearch $Notebook($w,pages) $name] |
||
| 241 | if {$i>=0} { |
||
| 242 | return $w.f$i |
||
| 243 | } else { |
||
| 244 | return {} |
||
| 245 | } |
||
| 246 | } |
||
| 247 | |||
| 248 | # |
||
| 249 | # Try to resize the notebook to the next time we become idle. |
||
| 250 | # |
||
| 251 | proc Notebook:scheduleExpand w { |
||
| 252 | global Notebook |
||
| 253 | if {[info exists Notebook($w,expand)]} return |
||
| 254 | set Notebook($w,expand) 1 |
||
| 255 | after idle "Notebook:expand $w" |
||
| 256 | } |
||
| 257 | |||
| 258 | # |
||
| 259 | # Resize the notebook to fit inside its containing widget. |
||
| 260 | # |
||
| 261 | proc Notebook:expand w { |
||
| 262 | global Notebook |
||
| 263 | set wi [expr [winfo width $w]-($Notebook($w,pad)*2+4)] |
||
| 264 | set hi [expr [winfo height $w]-($Notebook($w,pad)*2+36)] |
||
| 265 | Notebook:config $w -width $wi -height $hi |
||
| 266 | catch {unset Notebook($w,expand)} |
||
| 267 | } |
||
| 268 | |||
| 269 | # End of the notebook widget. |
||
| 270 | ################################# |
||
| 271 | |||
| 272 | ################################ Label Frame ############################# |
||
| 273 | # |
||
| 274 | # |
||
| 275 | proc LabelFrame:create {w args} { |
||
| 276 | frame $w -bd 0 |
||
| 277 | label $w.l |
||
| 278 | frame $w.f -bd 2 -relief groove |
||
| 279 | frame $w.f.f |
||
| 280 | pack $w.f.f |
||
| 281 | set text {} |
||
| 282 | set font {} |
||
| 283 | set padx 3 |
||
| 284 | set pady 7 |
||
| 285 | set ipadx 2 |
||
| 286 | set ipady 9 |
||
| 287 | foreach {tag value} $args { |
||
| 288 | switch -- $tag { |
||
| 289 | -font {set font $value} |
||
| 290 | -text {set text $value} |
||
| 291 | -padx {set padx $value} |
||
| 292 | -pady {set pady $value} |
||
| 293 | -ipadx {set ipadx $value} |
||
| 294 | -ipady {set ipady $value} |
||
| 295 | -bd {$w.f config -bd $value} |
||
| 296 | -relief {$w.f config -relief $value} |
||
| 297 | } |
||
| 298 | } |
||
| 299 | if {"$font"!=""} { |
||
| 300 | $w.l config -font $font |
||
| 301 | } |
||
| 302 | $w.l config -text $text |
||
| 303 | pack $w.f -padx $padx -pady $pady -fill both -expand 1 |
||
| 304 | place $w.l -x [expr $padx+10] -y $pady -anchor w |
||
| 305 | pack $w.f.f -padx $ipadx -pady $ipady -fill both -expand 1 |
||
| 306 | raise $w.l |
||
| 307 | return $w.f.f |
||
| 308 | } |
||
| 309 | # End of the labeled frame widget. |
||
| 310 | ######################################################## |
||
| 311 | |||
| 312 | ######################################################### |
||
| 313 | # Directory Selector TCL version 1.1 |
||
| 314 | # |
||
| 315 | # Originally written by: |
||
| 316 | # Daniel Roche, <dan@lectra.com> |
||
| 317 | # |
||
| 318 | # Modified for xmktclapp (and for version of Tk prior to 8.0) by: |
||
| 319 | # D. Richard Hipp, <drh@hwaci.com> |
||
| 320 | |||
| 321 | # tk_getDirectory [option value ...] |
||
| 322 | # |
||
| 323 | # options are : |
||
| 324 | # [-initialdir dir] display in dir |
||
| 325 | # [-title string] make string title of dialog window |
||
| 326 | # [-ok string] make string the label of OK button |
||
| 327 | # [-open string] make string the label of OPEN button |
||
| 328 | # [-cancel string] make string the label of CANCEL button |
||
| 329 | # [-msg1 string] make string the label of the first directory message |
||
| 330 | # [-msg2 string] make string the label of the second directory message |
||
| 331 | # |
||
| 332 | proc tk_getDirectory {args} { |
||
| 333 | global tcl_platform tk_getDirectory |
||
| 334 | |||
| 335 | # |
||
| 336 | # arguments |
||
| 337 | # |
||
| 338 | set _titre "Directory Selector" |
||
| 339 | set _ldir Directory: |
||
| 340 | set _ldnam "Directory Name:" |
||
| 341 | set _open Ok |
||
| 342 | set _expand Open |
||
| 343 | set _cancel Cancel |
||
| 344 | if {![info exists tk_getDirectory(curdir)]} { |
||
| 345 | set tk_getDirectory(curdir) [pwd] |
||
| 346 | } |
||
| 347 | |||
| 348 | set ind 0 |
||
| 349 | set max [llength $args] |
||
| 350 | while { $ind < $max } { |
||
| 351 | switch -exact -- [lindex $args $ind] { |
||
| 352 | "-initialdir" { |
||
| 353 | incr ind |
||
| 354 | set tk_getDirectory(curdir) [lindex $args $ind] |
||
| 355 | incr ind |
||
| 356 | } |
||
| 357 | "-title" { |
||
| 358 | incr ind |
||
| 359 | set _titre [lindex $args $ind] |
||
| 360 | incr ind |
||
| 361 | } |
||
| 362 | "-ok" { |
||
| 363 | incr ind |
||
| 364 | set _open [lindex $args $ind] |
||
| 365 | incr ind |
||
| 366 | } |
||
| 367 | "-open" { |
||
| 368 | incr ind |
||
| 369 | set _expand [lindex $args $ind] |
||
| 370 | incr ind |
||
| 371 | } |
||
| 372 | "-cancel" { |
||
| 373 | incr ind |
||
| 374 | set _cancel [lindex $args $ind] |
||
| 375 | incr ind |
||
| 376 | } |
||
| 377 | "-msg1" { |
||
| 378 | incr ind |
||
| 379 | set _ldir [lindex $args $ind] |
||
| 380 | incr ind |
||
| 381 | } |
||
| 382 | "-msg2" { |
||
| 383 | incr ind |
||
| 384 | set _ldnam [lindex $args $ind] |
||
| 385 | incr ind |
||
| 386 | } |
||
| 387 | default { |
||
| 388 | puts "unknown option [lindex $args $ind]" |
||
| 389 | return "" |
||
| 390 | } |
||
| 391 | } |
||
| 392 | } |
||
| 393 | |||
| 394 | # |
||
| 395 | # variables et data |
||
| 396 | # |
||
| 397 | set tk_getDirectory(fini) 0 |
||
| 398 | |||
| 399 | image create bitmap tk_getDirectory:b_up -data " |
||
| 400 | #define up_width 31 |
||
| 401 | #define up_height 23 |
||
| 402 | static unsigned char up_bits[] = { |
||
| 403 | 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, |
||
| 404 | 0x00, 0x00, 0x00, 0x80, 0x00, 0x3f, 0x00, 0x80, 0x80, 0x40, 0x00, 0x80, |
||
| 405 | 0x40, 0x80, 0x00, 0x80, 0xe0, 0xff, 0xff, 0x83, 0x20, 0x00, 0x00, 0x82, |
||
| 406 | 0x20, 0x04, 0x00, 0x82, 0x20, 0x0e, 0x00, 0x82, 0x20, 0x1f, 0x00, 0x82, |
||
| 407 | 0x20, 0x04, 0x00, 0x82, 0x20, 0x04, 0x00, 0x82, 0x20, 0x04, 0x00, 0x82, |
||
| 408 | 0x20, 0xfc, 0x0f, 0x82, 0x20, 0x00, 0x00, 0x82, 0x20, 0x00, 0x00, 0x82, |
||
| 409 | 0xe0, 0xff, 0xff, 0x83, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80, |
||
| 410 | 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x80};" |
||
| 411 | |||
| 412 | image create bitmap tk_getDirectory:b_dir -background #ffff80 -data " |
||
| 413 | #define dir_width 17 |
||
| 414 | #define dir_height 16 |
||
| 415 | static unsigned char dir_bits[] = { |
||
| 416 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, 0x10, 0x02, 0x00, |
||
| 417 | 0x08, 0x04, 0x00, 0xfc, 0x7f, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, |
||
| 418 | 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, 0x04, 0x40, 0x00, |
||
| 419 | 0x04, 0x40, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" \ |
||
| 420 | -maskdata " |
||
| 421 | #define dirm_width 17 |
||
| 422 | #define dirm_height 16 |
||
| 423 | static unsigned char dirm_bits[] = { |
||
| 424 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, 0xf0, 0x03, 0x00, |
||
| 425 | 0xf8, 0x07, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, |
||
| 426 | 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, |
||
| 427 | 0xfc, 0x7f, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 428 | |||
| 429 | switch -exact $tcl_platform(platform) { |
||
| 430 | unix { |
||
| 431 | set tk_getDirectory(myfont) \ |
||
| 432 | -adobe-helvetica-bold-r-normal-*-12-120-75-75-p-70-iso8859-1 |
||
| 433 | } |
||
| 434 | windows { |
||
| 435 | set tk_getDirectory(myfont) {Courier 12} |
||
| 436 | } |
||
| 437 | } |
||
| 438 | |||
| 439 | # |
||
| 440 | # widgets |
||
| 441 | # |
||
| 442 | if {[winfo exists .dirsel]} {destroy .dirsel} |
||
| 443 | toplevel .dirsel |
||
| 444 | grab set .dirsel |
||
| 445 | wm geometry .dirsel 500x250 |
||
| 446 | wm title .dirsel $_titre |
||
| 447 | |||
| 448 | frame .dirsel.f1 -relief flat -borderwidth 0 |
||
| 449 | frame .dirsel.f2 -relief sunken -borderwidth 2 |
||
| 450 | frame .dirsel.f3 -relief flat -borderwidth 0 |
||
| 451 | frame .dirsel.f4 -relief flat -borderwidth 0 |
||
| 452 | |||
| 453 | pack .dirsel.f1 -fill x |
||
| 454 | pack .dirsel.f2 -fill both -expand 1 -padx 6 -pady 6 |
||
| 455 | pack .dirsel.f3 -fill x |
||
| 456 | pack .dirsel.f4 -fill x |
||
| 457 | |||
| 458 | label .dirsel.f1.lab -text $_ldir |
||
| 459 | menubutton .dirsel.f1.dir -relief raised -indicatoron 1 -anchor w \ |
||
| 460 | -menu .dirsel.f1.dir.m |
||
| 461 | menu .dirsel.f1.dir.m -tearoff 0 |
||
| 462 | button .dirsel.f1.up -image tk_getDirectory:b_up \ |
||
| 463 | -command tk_getDirectory:UpDir |
||
| 464 | |||
| 465 | pack .dirsel.f1.up -side right -padx 4 -pady 4 |
||
| 466 | pack .dirsel.f1.lab -side left -padx 4 -pady 4 |
||
| 467 | pack .dirsel.f1.dir -side right -padx 4 -pady 4 -fill x -expand 1 |
||
| 468 | |||
| 469 | canvas .dirsel.f2.cv -borderwidth 0 -xscrollcommand ".dirsel.f2.sb set" \ |
||
| 470 | -height 10 -bg white |
||
| 471 | scrollbar .dirsel.f2.sb -command ".dirsel.f2.cv xview" -orient horizontal |
||
| 472 | pack .dirsel.f2.cv -side top -fill both -expand 1 |
||
| 473 | pack .dirsel.f2.sb -side top -fill x |
||
| 474 | |||
| 475 | .dirsel.f2.cv bind TXT <Any-Button> tk_getDirectory:ClickItem |
||
| 476 | .dirsel.f2.cv bind IMG <Any-Button> tk_getDirectory:ClickItem |
||
| 477 | |||
| 478 | button .dirsel.f4.open -text $_open \ |
||
| 479 | -command {set tk_getDirectory(fini) 1} |
||
| 480 | button .dirsel.f4.cancel -text $_cancel \ |
||
| 481 | -command {set tk_getDirectory(fini) -1} |
||
| 482 | pack .dirsel.f4.open -side left -padx 25 -pady 4 |
||
| 483 | pack .dirsel.f4.cancel -side right -padx 25 -pady 4 |
||
| 484 | |||
| 485 | # Withdraw the window, then update all the geometry information |
||
| 486 | # so we know how big it wants to be, then center the window in the |
||
| 487 | # display and de-iconify it. |
||
| 488 | |||
| 489 | wm withdraw .dirsel |
||
| 490 | update |
||
| 491 | set p [winfo parent .dirsel] |
||
| 492 | regsub -all {\+\-} [wm geometry $p] {-} geom |
||
| 493 | scan $geom %dx%d%d%d pw ph px py |
||
| 494 | set x [expr {$px + ($pw - 500)/2}] |
||
| 495 | set y [expr {$py + ($ph - 250)/2}] |
||
| 496 | if {$x<0} {set x 0} |
||
| 497 | if {$y<0} {set y 0} |
||
| 498 | wm geom .dirsel +$x+$y |
||
| 499 | wm deiconify .dirsel |
||
| 500 | |||
| 501 | # |
||
| 502 | # realwork |
||
| 503 | # |
||
| 504 | tk_getDirectory:ShowDir $tk_getDirectory(curdir) |
||
| 505 | |||
| 506 | # |
||
| 507 | # wait user |
||
| 508 | # |
||
| 509 | tkwait variable tk_getDirectory(fini) |
||
| 510 | |||
| 511 | if { $tk_getDirectory(fini) == 1 } { |
||
| 512 | set retval [.dirsel.f1.dir cget -text] |
||
| 513 | } else { |
||
| 514 | set retval "" |
||
| 515 | } |
||
| 516 | |||
| 517 | destroy .dirsel |
||
| 518 | global tk_getDirectory_xref |
||
| 519 | catch {unset tk_getDirectory_xref} |
||
| 520 | # unset tk_getDirectory |
||
| 521 | return $retval |
||
| 522 | } |
||
| 523 | |||
| 524 | proc tk_getDirectory:ShowDir {curdir} { |
||
| 525 | global tcl_platform tk_getDirectory tk_getDirectory_xref |
||
| 526 | |||
| 527 | set tk_getDirectory(curdir) $curdir |
||
| 528 | .dirsel.f1.dir configure -text $curdir |
||
| 529 | |||
| 530 | set hi [image height tk_getDirectory:b_dir] |
||
| 531 | set wi [image width tk_getDirectory:b_dir] |
||
| 532 | incr wi 4 |
||
| 533 | update |
||
| 534 | set maxy [expr [winfo height .dirsel.f2.cv]-$hi] |
||
| 535 | |||
| 536 | set lidir [list] |
||
| 537 | foreach file [glob -nocomplain $curdir/*] { |
||
| 538 | if [ file isdirectory $file ] { |
||
| 539 | lappend lidir [file tail $file] |
||
| 540 | } |
||
| 541 | } |
||
| 542 | set sldir [lsort $lidir] |
||
| 543 | |||
| 544 | .dirsel.f2.cv delete all |
||
| 545 | set ind 0 |
||
| 546 | set x 2 |
||
| 547 | set y 2 |
||
| 548 | catch {unset tk_getDirectory_xref} |
||
| 549 | foreach file $sldir { |
||
| 550 | set id [.dirsel.f2.cv create image $x $y \ |
||
| 551 | -anchor nw -image tk_getDirectory:b_dir -tags IMG] |
||
| 552 | set tk_getDirectory_xref($id) $file |
||
| 553 | set id [.dirsel.f2.cv create text [expr $x+$wi] $y \ |
||
| 554 | -anchor nw -text $file -font $tk_getDirectory(myfont) -tags TXT] |
||
| 555 | set tk_getDirectory_xref($id) $file |
||
| 556 | incr y $hi |
||
| 557 | if {$y>=$maxy} { |
||
| 558 | set bbox [.dirsel.f2.cv bbox all] |
||
| 559 | set x [expr [lindex $bbox 2]+10] |
||
| 560 | set y 2 |
||
| 561 | } |
||
| 562 | } |
||
| 563 | .dirsel.f2.cv configure -scrollregion [.dirsel.f2.cv bbox all] |
||
| 564 | |||
| 565 | set curlst [file split $curdir] |
||
| 566 | set nbr [llength $curlst] |
||
| 567 | |||
| 568 | .dirsel.f1.dir.m delete 0 last |
||
| 569 | incr nbr -2 |
||
| 570 | for {set ind $nbr} {$ind >= 0} {incr ind -1} { |
||
| 571 | set tmplst [ lrange $curlst 0 $ind] |
||
| 572 | set tmpdir [ eval file join $tmplst] |
||
| 573 | .dirsel.f1.dir.m add command -label $tmpdir \ |
||
| 574 | -command "tk_getDirectory:ShowDir [list $tmpdir]" |
||
| 575 | } |
||
| 576 | if {[info exist tk_getDirectory(drives)] == 0} { |
||
| 577 | update |
||
| 578 | if {[catch {file volume} tk_getDirectory(drives)]} { |
||
| 579 | set tk_getDirectory(drives) {} |
||
| 580 | } |
||
| 581 | } |
||
| 582 | if ![string compare $tcl_platform(platform) windows] { |
||
| 583 | foreach drive $tk_getDirectory(drives) { |
||
| 584 | .dirsel.f1.dir.m add command -label $drive \ |
||
| 585 | -command "tk_getDirectory:ShowDir [list $drive]" |
||
| 586 | } |
||
| 587 | } |
||
| 588 | |||
| 589 | } |
||
| 590 | |||
| 591 | proc tk_getDirectory:UpDir {} { |
||
| 592 | set curdir [.dirsel.f1.dir cget -text] |
||
| 593 | set curlst [file split $curdir] |
||
| 594 | set nbr [llength $curlst] |
||
| 595 | if { $nbr < 2 } { |
||
| 596 | return |
||
| 597 | } |
||
| 598 | set tmp [expr $nbr - 2] |
||
| 599 | set newlst [ lrange $curlst 0 $tmp ] |
||
| 600 | set newdir [ eval file join $newlst ] |
||
| 601 | tk_getDirectory:ShowDir $newdir |
||
| 602 | } |
||
| 603 | |||
| 604 | proc tk_getDirectory:ClickItem {} { |
||
| 605 | global tk_getDirectory tk_getDirectory_xref |
||
| 606 | set id [.dirsel.f2.cv find withtag current] |
||
| 607 | if {[catch {set tk_getDirectory_xref($id)} dir]} { |
||
| 608 | if {[catch {.dirsel.f2.cv itemcget $id -text} dir]} { |
||
| 609 | return |
||
| 610 | } |
||
| 611 | } |
||
| 612 | if {[string length $dir]==0} return |
||
| 613 | tk_getDirectory:ShowDir [file join $tk_getDirectory(curdir) $dir] |
||
| 614 | } |
||
| 615 | |||
| 616 | # |
||
| 617 | # End tk_getDirectory widget |
||
| 618 | ######################################################################## |
||
| 619 | |||
| 620 | ######################################################################## |
||
| 621 | # |
||
| 622 | # This version of msgbox.tcl has been modified in two ways: |
||
| 623 | # |
||
| 624 | # 1. Color icons are used on Unix displays that have a color |
||
| 625 | # depth of 4 or more. Most users like the color icons better. |
||
| 626 | # |
||
| 627 | # 2. The button on error dialog boxes says "Bummer" instead of |
||
| 628 | # "OK", because errors are not ok. |
||
| 629 | # |
||
| 630 | # Other than that, the code is identical and should be fully |
||
| 631 | # backwards compatible. |
||
| 632 | # |
||
| 633 | |||
| 634 | image create bitmap tkPriv:b1 -foreground black \ |
||
| 635 | -data "#define b1_width 32\n#define b1_height 32 |
||
| 636 | static unsigned char q1_bits[] = { |
||
| 637 | 0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03, |
||
| 638 | 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, |
||
| 639 | 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40, |
||
| 640 | 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, |
||
| 641 | 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, |
||
| 642 | 0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40, |
||
| 643 | 0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08, |
||
| 644 | 0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00, |
||
| 645 | 0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, |
||
| 646 | 0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00, |
||
| 647 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 648 | image create bitmap tkPriv:b2 -foreground white \ |
||
| 649 | -data "#define b2_width 32\n#define b2_height 32 |
||
| 650 | static unsigned char b2_bits[] = { |
||
| 651 | 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00, |
||
| 652 | 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, |
||
| 653 | 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f, |
||
| 654 | 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, |
||
| 655 | 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, |
||
| 656 | 0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f, |
||
| 657 | 0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07, |
||
| 658 | 0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00, |
||
| 659 | 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, |
||
| 660 | 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 661 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 662 | image create bitmap tkPriv:q -foreground blue \ |
||
| 663 | -data "#define q_width 32\n#define q_height 32 |
||
| 664 | static unsigned char q_bits[] = { |
||
| 665 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 666 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00, |
||
| 667 | 0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00, |
||
| 668 | 0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00, |
||
| 669 | 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, |
||
| 670 | 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00, |
||
| 671 | 0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 672 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 673 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 674 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 675 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 676 | image create bitmap tkPriv:i -foreground blue \ |
||
| 677 | -data "#define i_width 32\n#define i_height 32 |
||
| 678 | static unsigned char i_bits[] = { |
||
| 679 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 680 | 0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, |
||
| 681 | 0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 682 | 0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, |
||
| 683 | 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, |
||
| 684 | 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00, |
||
| 685 | 0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 686 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 687 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 688 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 689 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 690 | image create bitmap tkPriv:w1 -foreground black \ |
||
| 691 | -data "#define w1_width 32\n#define w1_height 32 |
||
| 692 | static unsigned char w1_bits[] = { |
||
| 693 | 0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00, |
||
| 694 | 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, |
||
| 695 | 0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00, |
||
| 696 | 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, |
||
| 697 | 0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01, |
||
| 698 | 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, |
||
| 699 | 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, |
||
| 700 | 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, |
||
| 701 | 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40, |
||
| 702 | 0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, |
||
| 703 | 0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};" |
||
| 704 | image create bitmap tkPriv:w2 -foreground yellow \ |
||
| 705 | -data "#define w2_width 32\n#define w2_height 32 |
||
| 706 | static unsigned char w2_bits[] = { |
||
| 707 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00, |
||
| 708 | 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00, |
||
| 709 | 0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00, |
||
| 710 | 0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00, |
||
| 711 | 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00, |
||
| 712 | 0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01, |
||
| 713 | 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, |
||
| 714 | 0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f, |
||
| 715 | 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f, |
||
| 716 | 0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f, |
||
| 717 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 718 | image create bitmap tkPriv:w3 -foreground black \ |
||
| 719 | -data "#define w3_width 32\n#define w3_height 32 |
||
| 720 | static unsigned char w3_bits[] = { |
||
| 721 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 722 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 723 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 724 | 0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, |
||
| 725 | 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, |
||
| 726 | 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, |
||
| 727 | 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, |
||
| 728 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00, |
||
| 729 | 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 730 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, |
||
| 731 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};" |
||
| 732 | |||
| 733 | # tkMessageBox -- |
||
| 734 | # |
||
| 735 | # Pops up a messagebox with an application-supplied message with |
||
| 736 | # an icon and a list of buttons. This procedure will be called |
||
| 737 | # by tk_messageBox if the platform does not have native |
||
| 738 | # messagebox support, or if the particular type of messagebox is |
||
| 739 | # not supported natively. |
||
| 740 | # |
||
| 741 | # This procedure is a private procedure shouldn't be called |
||
| 742 | # directly. Call tk_messageBox instead. |
||
| 743 | # |
||
| 744 | # See the user documentation for details on what tk_messageBox does. |
||
| 745 | # |
||
| 746 | proc tkMessageBox {args} { |
||
| 747 | global tkPriv tcl_platform |
||
| 748 | |||
| 749 | set w tkPrivMsgBox |
||
| 750 | upvar #0 $w data |
||
| 751 | |||
| 752 | # |
||
| 753 | # The default value of the title is space (" ") not the empty string |
||
| 754 | # because for some window managers, a |
||
| 755 | # wm title .foo "" |
||
| 756 | # causes the window title to be "foo" instead of the empty string. |
||
| 757 | # |
||
| 758 | set specs { |
||
| 759 | {-default "" "" ""} |
||
| 760 | {-icon "" "" "info"} |
||
| 761 | {-message "" "" ""} |
||
| 762 | {-parent "" "" .} |
||
| 763 | {-title "" "" " "} |
||
| 764 | {-type "" "" "ok"} |
||
| 765 | } |
||
| 766 | |||
| 767 | tclParseConfigSpec $w $specs "" $args |
||
| 768 | |||
| 769 | if {[lsearch {info warning error question} $data(-icon)] == -1} { |
||
| 770 | error "invalid icon \"$data(-icon)\", must be error, info, question or warning" |
||
| 771 | } |
||
| 772 | if {$tcl_platform(platform) == "macintosh"} { |
||
| 773 | if {$data(-icon) == "error"} { |
||
| 774 | set data(-icon) "stop" |
||
| 775 | } elseif {$data(-icon) == "warning"} { |
||
| 776 | set data(-icon) "caution" |
||
| 777 | } elseif {$data(-icon) == "info"} { |
||
| 778 | set data(-icon) "note" |
||
| 779 | } |
||
| 780 | } |
||
| 781 | |||
| 782 | if {![winfo exists $data(-parent)]} { |
||
| 783 | error "bad window path name \"$data(-parent)\"" |
||
| 784 | } |
||
| 785 | |||
| 786 | case $data(-type) { |
||
| 787 | abortretryignore { |
||
| 788 | set buttons { |
||
| 789 | {abort -width 6 -text Abort -under 0} |
||
| 790 | {retry -width 6 -text Retry -under 0} |
||
| 791 | {ignore -width 6 -text Ignore -under 0} |
||
| 792 | } |
||
| 793 | } |
||
| 794 | ok { |
||
| 795 | if {$data(-icon) == "error"} { |
||
| 796 | set buttons { |
||
| 797 | {ok -width 6 -text Bummer -under 0} |
||
| 798 | } |
||
| 799 | } else { |
||
| 800 | set buttons { |
||
| 801 | {ok -width 6 -text OK -under 0} |
||
| 802 | } |
||
| 803 | } |
||
| 804 | if {$data(-default) == ""} { |
||
| 805 | set data(-default) "ok" |
||
| 806 | } |
||
| 807 | } |
||
| 808 | okcancel { |
||
| 809 | set buttons { |
||
| 810 | {ok -width 6 -text OK -under 0} |
||
| 811 | {cancel -width 6 -text Cancel -under 0} |
||
| 812 | } |
||
| 813 | } |
||
| 814 | retrycancel { |
||
| 815 | set buttons { |
||
| 816 | {retry -width 6 -text Retry -under 0} |
||
| 817 | {cancel -width 6 -text Cancel -under 0} |
||
| 818 | } |
||
| 819 | } |
||
| 820 | yesno { |
||
| 821 | set buttons { |
||
| 822 | {yes -width 6 -text Yes -under 0} |
||
| 823 | {no -width 6 -text No -under 0} |
||
| 824 | } |
||
| 825 | } |
||
| 826 | yesnocancel { |
||
| 827 | set buttons { |
||
| 828 | {yes -width 6 -text Yes -under 0} |
||
| 829 | {no -width 6 -text No -under 0} |
||
| 830 | {cancel -width 6 -text Cancel -under 0} |
||
| 831 | } |
||
| 832 | } |
||
| 833 | default { |
||
| 834 | error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel" |
||
| 835 | } |
||
| 836 | } |
||
| 837 | |||
| 838 | if {[string compare $data(-default) ""]} { |
||
| 839 | set valid 0 |
||
| 840 | foreach btn $buttons { |
||
| 841 | if {![string compare [lindex $btn 0] $data(-default)]} { |
||
| 842 | set valid 1 |
||
| 843 | break |
||
| 844 | } |
||
| 845 | } |
||
| 846 | if {!$valid} { |
||
| 847 | error "invalid default button \"$data(-default)\"" |
||
| 848 | } |
||
| 849 | } |
||
| 850 | |||
| 851 | # 2. Set the dialog to be a child window of $parent |
||
| 852 | # |
||
| 853 | # |
||
| 854 | if {[string compare $data(-parent) .]} { |
||
| 855 | set w $data(-parent).__tk__messagebox |
||
| 856 | } else { |
||
| 857 | set w .__tk__messagebox |
||
| 858 | } |
||
| 859 | |||
| 860 | # 3. Create the top-level window and divide it into top |
||
| 861 | # and bottom parts. |
||
| 862 | |||
| 863 | catch {destroy $w} |
||
| 864 | toplevel $w -class Dialog |
||
| 865 | wm title $w $data(-title) |
||
| 866 | wm iconname $w Dialog |
||
| 867 | wm protocol $w WM_DELETE_WINDOW { } |
||
| 868 | wm transient $w $data(-parent) |
||
| 869 | if {$tcl_platform(platform) == "macintosh"} { |
||
| 870 | unsupported1 style $w dBoxProc |
||
| 871 | } |
||
| 872 | |||
| 873 | frame $w.bot |
||
| 874 | pack $w.bot -side bottom -fill both |
||
| 875 | frame $w.top |
||
| 876 | pack $w.top -side top -fill both -expand 1 |
||
| 877 | if {$tcl_platform(platform) != "macintosh"} { |
||
| 878 | $w.bot configure -relief raised -bd 1 |
||
| 879 | $w.top configure -relief raised -bd 1 |
||
| 880 | } |
||
| 881 | |||
| 882 | # 4. Fill the top part with bitmap and message (use the option |
||
| 883 | # database for -wraplength so that it can be overridden by |
||
| 884 | # the caller). |
||
| 885 | |||
| 886 | option add *Dialog.msg.wrapLength 3i widgetDefault |
||
| 887 | label $w.msg -justify left -text $data(-message) |
||
| 888 | catch {$w.msg configure -font \ |
||
| 889 | -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* |
||
| 890 | } |
||
| 891 | pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m |
||
| 892 | if {$data(-icon) != ""} { |
||
| 893 | if {$tcl_platform(platform)=="macintosh" || [winfo depth $w]<4} { |
||
| 894 | label $w.bitmap -bitmap $data(-icon) |
||
| 895 | } else { |
||
| 896 | canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 |
||
| 897 | switch $data(-icon) { |
||
| 898 | error { |
||
| 899 | $w.bitmap create oval 0 0 31 31 -fill red -outline black |
||
| 900 | $w.bitmap create line 9 9 23 23 -fill white -width 4 |
||
| 901 | $w.bitmap create line 9 23 23 9 -fill white -width 4 |
||
| 902 | } |
||
| 903 | info { |
||
| 904 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:b1 |
||
| 905 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:b2 |
||
| 906 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:i |
||
| 907 | } |
||
| 908 | question { |
||
| 909 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:b1 |
||
| 910 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:b2 |
||
| 911 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:q |
||
| 912 | } |
||
| 913 | default { |
||
| 914 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:w1 |
||
| 915 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:w2 |
||
| 916 | $w.bitmap create image 0 0 -anchor nw -image tkPriv:w3 |
||
| 917 | } |
||
| 918 | } |
||
| 919 | } |
||
| 920 | pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m |
||
| 921 | } |
||
| 922 | |||
| 923 | # 5. Create a row of buttons at the bottom of the dialog. |
||
| 924 | |||
| 925 | set i 0 |
||
| 926 | foreach but $buttons { |
||
| 927 | set name [lindex $but 0] |
||
| 928 | set opts [lrange $but 1 end] |
||
| 929 | if {![string compare $opts {}]} { |
||
| 930 | # Capitalize the first letter of $name |
||
| 931 | set capName \ |
||
| 932 | [string toupper \ |
||
| 933 | [string index $name 0]][string range $name 1 end] |
||
| 934 | set opts [list -text $capName] |
||
| 935 | } |
||
| 936 | |||
| 937 | eval button $w.$name $opts -command [list "set tkPriv(button) $name"] |
||
| 938 | |||
| 939 | if {![string compare $name $data(-default)]} { |
||
| 940 | catch {$w.$name configure -default active} |
||
| 941 | } |
||
| 942 | pack $w.$name -in $w.bot -side left -expand 1 \ |
||
| 943 | -padx 3m -pady 2m |
||
| 944 | |||
| 945 | # create the binding for the key accelerator, based on the underline |
||
| 946 | # |
||
| 947 | set underIdx [$w.$name cget -under] |
||
| 948 | if {$underIdx >= 0} { |
||
| 949 | set key [string index [$w.$name cget -text] $underIdx] |
||
| 950 | bind $w <Alt-[string tolower $key]> "$w.$name invoke" |
||
| 951 | bind $w <Alt-[string toupper $key]> "$w.$name invoke" |
||
| 952 | } |
||
| 953 | incr i |
||
| 954 | } |
||
| 955 | |||
| 956 | # 6. Create a binding for <Return> on the dialog if there is a |
||
| 957 | # default button. |
||
| 958 | |||
| 959 | if {[string compare $data(-default) ""]} { |
||
| 960 | bind $w <Return> "tkButtonInvoke $w.$data(-default)" |
||
| 961 | } |
||
| 962 | |||
| 963 | # 7. Withdraw the window, then update all the geometry information |
||
| 964 | # so we know how big it wants to be, then center the window in the |
||
| 965 | # display and de-iconify it. |
||
| 966 | |||
| 967 | wm withdraw $w |
||
| 968 | update idletasks |
||
| 969 | set p [winfo parent $w] |
||
| 970 | regsub -all {\+\-} [wm geometry $p] {-} geom |
||
| 971 | scan $geom %dx%d%d%d pw ph px py |
||
| 972 | set x [expr {$px + ($pw - [winfo reqwidth $w])/2}] |
||
| 973 | set y [expr {$py + ($ph - [winfo reqheight $w])/2}] |
||
| 974 | if {$x<0} {set x 0} |
||
| 975 | if {$y<0} {set y 0} |
||
| 976 | wm geom $w +$x+$y |
||
| 977 | wm deiconify $w |
||
| 978 | |||
| 979 | # 8. Set a grab and claim the focus too. |
||
| 980 | |||
| 981 | set oldFocus [focus] |
||
| 982 | set oldGrab [grab current $w] |
||
| 983 | if {$oldGrab != ""} { |
||
| 984 | set grabStatus [grab status $oldGrab] |
||
| 985 | } |
||
| 986 | grab $w |
||
| 987 | if {[string compare $data(-default) ""]} { |
||
| 988 | focus $w.$data(-default) |
||
| 989 | } else { |
||
| 990 | focus $w |
||
| 991 | } |
||
| 992 | |||
| 993 | # 9. Wait for the user to respond, then restore the focus and |
||
| 994 | # return the index of the selected button. Restore the focus |
||
| 995 | # before deleting the window, since otherwise the window manager |
||
| 996 | # may take the focus away so we can't redirect it. Finally, |
||
| 997 | # restore any grab that was in effect. |
||
| 998 | |||
| 999 | tkwait variable tkPriv(button) |
||
| 1000 | catch {focus $oldFocus} |
||
| 1001 | destroy $w |
||
| 1002 | if {$oldGrab != ""} { |
||
| 1003 | if {$grabStatus == "global"} { |
||
| 1004 | grab -global $oldGrab |
||
| 1005 | } else { |
||
| 1006 | grab $oldGrab |
||
| 1007 | } |
||
| 1008 | } |
||
| 1009 | return $tkPriv(button) |
||
| 1010 | } |
||
| 1011 | # |
||
| 1012 | ##################### End Tk_MessageBox ############################ |
||
| 1013 | |||
| 1014 | #################### Begin Console Wdiget ########################## |
||
| 1015 | # A console widget for Tcl/Tk. Invoke OpenConsole with a window name |
||
| 1016 | # and prompt string to get a new top-level window that allows the |
||
| 1017 | # user to enter tcl commands. This is mainly useful for testing and |
||
| 1018 | # debugging. |
||
| 1019 | # |
||
| 1020 | # Copyright (C) 1998 D. Richard Hipp |
||
| 1021 | # |
||
| 1022 | # This library is free software; you can redistribute it and/or |
||
| 1023 | # modify it under the terms of the GNU Library General Public |
||
| 1024 | # License as published by the Free Software Foundation; either |
||
| 1025 | # version 2 of the License, or (at your option) any later version. |
||
| 1026 | # |
||
| 1027 | # This library is distributed in the hope that it will be useful, |
||
| 1028 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
||
| 1029 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
||
| 1030 | # Library General Public License for more details. |
||
| 1031 | # |
||
| 1032 | # You should have received a copy of the GNU Library General Public |
||
| 1033 | # License along with this library; if not, write to the |
||
| 1034 | # Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
||
| 1035 | # Boston, MA 02111-1307, USA. |
||
| 1036 | # |
||
| 1037 | # Author contact information: |
||
| 1038 | # drh@acm.org |
||
| 1039 | # http://www.hwaci.com/drh/ |
||
| 1040 | |||
| 1041 | |||
| 1042 | proc OpenConsole {w prompt} { |
||
| 1043 | upvar #0 $w.t v |
||
| 1044 | if {[winfo exists $w]} {destroy $w} |
||
| 1045 | catch {unset v} |
||
| 1046 | toplevel $w |
||
| 1047 | wm title $w {Test And Debug Console} |
||
| 1048 | wm iconname $w {Console} |
||
| 1049 | button $w.quit -text Dismiss -command "destroy $w" |
||
| 1050 | pack $w.quit -side bottom |
||
| 1051 | scrollbar $w.sb -orient vertical -command "$w.t yview" |
||
| 1052 | pack $w.sb -side right -fill y |
||
| 1053 | text $w.t -font fixed -yscrollcommand "$w.sb set" |
||
| 1054 | pack $w.t -side right -fill both -expand 1 |
||
| 1055 | bindtags $w.t Console |
||
| 1056 | set v(text) $w.t |
||
| 1057 | set v(history) 0 |
||
| 1058 | set v(historycnt) 0 |
||
| 1059 | set v(current) -1 |
||
| 1060 | set v(prompt) $prompt |
||
| 1061 | set v(plength) [string length $v(prompt)] |
||
| 1062 | $w.t insert end $v(prompt) |
||
| 1063 | $w.t mark set insert end |
||
| 1064 | $w.t tag config ok -foreground blue |
||
| 1065 | $w.t tag config err -foreground red |
||
| 1066 | after idle "focus $w.t" |
||
| 1067 | } |
||
| 1068 | |||
| 1069 | bind Console <1> {focus %W} |
||
| 1070 | bind Console <KeyPress> {conInsert %W %A} |
||
| 1071 | bind Console <Left> {conLeft %W} |
||
| 1072 | bind Console <Control-b> {conLeft %W} |
||
| 1073 | bind Console <Right> {conRight %W} |
||
| 1074 | bind Console <Control-f> {conRight %W} |
||
| 1075 | bind Console <BackSpace> {conBackspace %W} |
||
| 1076 | bind Console <Control-h> {conBackspace %W} |
||
| 1077 | bind Console <Delete> {conDelete %W} |
||
| 1078 | bind Console <Control-d> {conDelete %W} |
||
| 1079 | bind Console <Home> {conHome %W} |
||
| 1080 | bind Console <Control-a> {conHome %W} |
||
| 1081 | bind Console <End> {conEnd %W} |
||
| 1082 | bind Console <Control-e> {conEnd %W} |
||
| 1083 | bind Console <Return> {conEnter %W} |
||
| 1084 | bind Console <KP_Enter> {conEnter %W} |
||
| 1085 | bind Console <Up> {conPrior %W} |
||
| 1086 | bind Console <Control-p> {conPrior %W} |
||
| 1087 | bind Console <Down> {conNext %W} |
||
| 1088 | bind Console <Control-n> {conNext %W} |
||
| 1089 | |||
| 1090 | # Insert a single character at the insertion cursor |
||
| 1091 | # |
||
| 1092 | proc conInsert {w a} { |
||
| 1093 | $w insert insert $a |
||
| 1094 | } |
||
| 1095 | |||
| 1096 | # Move the cursor one character to the left |
||
| 1097 | # |
||
| 1098 | proc conLeft {w} { |
||
| 1099 | upvar #0 $w v |
||
| 1100 | scan [$w index insert] %d.%d row col |
||
| 1101 | if {$col>$v(plength)} { |
||
| 1102 | $w mark set insert "insert -1c" |
||
| 1103 | } |
||
| 1104 | } |
||
| 1105 | |||
| 1106 | # Erase the character to the left of the cursor |
||
| 1107 | # |
||
| 1108 | proc conBackspace {w} { |
||
| 1109 | upvar #0 $w v |
||
| 1110 | scan [$w index insert] %d.%d row col |
||
| 1111 | if {$col>$v(plength)} { |
||
| 1112 | $w delete {insert -1c} |
||
| 1113 | } |
||
| 1114 | } |
||
| 1115 | |||
| 1116 | # Move the cursor one character to the right |
||
| 1117 | # |
||
| 1118 | proc conRight {w} { |
||
| 1119 | $w mark set insert "insert +1c" |
||
| 1120 | } |
||
| 1121 | |||
| 1122 | # Erase the character to the right of the cursor |
||
| 1123 | # |
||
| 1124 | proc conDelete w { |
||
| 1125 | $w delete insert |
||
| 1126 | } |
||
| 1127 | |||
| 1128 | # Move the cursor to the beginning of the current line |
||
| 1129 | # |
||
| 1130 | proc conHome w { |
||
| 1131 | upvar #0 $w v |
||
| 1132 | scan [$w index insert] %d.%d row col |
||
| 1133 | $w mark set insert $row.$v(plength) |
||
| 1134 | } |
||
| 1135 | |||
| 1136 | # Move the cursor to the end of the current line |
||
| 1137 | # |
||
| 1138 | proc conEnd w { |
||
| 1139 | $w mark set insert {insert lineend} |
||
| 1140 | } |
||
| 1141 | |||
| 1142 | # Called when "Enter" is pressed. Do something with the line |
||
| 1143 | # of text that was entered. |
||
| 1144 | # |
||
| 1145 | proc conEnter w { |
||
| 1146 | upvar #0 $w v |
||
| 1147 | scan [$w index insert] %d.%d row col |
||
| 1148 | set start $row.$v(plength) |
||
| 1149 | set line [$w get $start "$start lineend"] |
||
| 1150 | if {$v(historycnt)>0} { |
||
| 1151 | set last [lindex $v(history) [expr $v(historycnt)-1]] |
||
| 1152 | if {[string compare $last $line]} { |
||
| 1153 | lappend v(history) $line |
||
| 1154 | incr v(historycnt) |
||
| 1155 | } |
||
| 1156 | } else { |
||
| 1157 | set v(history) [list $line] |
||
| 1158 | set v(historycnt) 1 |
||
| 1159 | } |
||
| 1160 | set v(current) $v(historycnt) |
||
| 1161 | $w insert end \n |
||
| 1162 | if {[catch {uplevel #0 $line} res]} { |
||
| 1163 | $w insert end $res\n err |
||
| 1164 | } elseif {[string length $res]>0} { |
||
| 1165 | $w insert end $res\n ok |
||
| 1166 | } |
||
| 1167 | $w insert end $v(prompt) |
||
| 1168 | $w mark set insert end |
||
| 1169 | $w yview insert |
||
| 1170 | } |
||
| 1171 | |||
| 1172 | # Change the line to the previous line |
||
| 1173 | # |
||
| 1174 | proc conPrior w { |
||
| 1175 | upvar #0 $w v |
||
| 1176 | if {$v(current)<=0} return |
||
| 1177 | incr v(current) -1 |
||
| 1178 | set line [lindex $v(history) $v(current)] |
||
| 1179 | conSetLine $w $line |
||
| 1180 | } |
||
| 1181 | |||
| 1182 | # Change the line to the next line |
||
| 1183 | # |
||
| 1184 | proc conNext w { |
||
| 1185 | upvar #0 $w v |
||
| 1186 | if {$v(current)>=$v(historycnt)} return |
||
| 1187 | incr v(current) 1 |
||
| 1188 | set line [lindex $v(history) $v(current)] |
||
| 1189 | conSetLine $w $line |
||
| 1190 | } |
||
| 1191 | |||
| 1192 | # Change the contents of the entry line |
||
| 1193 | # |
||
| 1194 | proc conSetLine {w line} { |
||
| 1195 | upvar #0 $w v |
||
| 1196 | scan [$w index insert] %d.%d row col |
||
| 1197 | set start $row.$v(plength) |
||
| 1198 | $w delete $start end |
||
| 1199 | $w insert end $line |
||
| 1200 | $w mark set insert end |
||
| 1201 | $w yview insert |
||
| 1202 | } |
||
| 1203 | ########################### End Console Widget ########################### |
||
| 1204 | |||
| 1205 | # A configuration file can be read either by this program (the |
||
| 1206 | # xmktclapp GUI) or by the command-line based mktclapp program. |
||
| 1207 | # But each program reads different parts of the same file. |
||
| 1208 | # |
||
| 1209 | # Mktclapp treats each line that begins with '#' as a comment. |
||
| 1210 | # Xmktclapp reads only those lines that begin with '##'. Hence, |
||
| 1211 | # each program reads a different part of the same file. |
||
| 1212 | |||
| 1213 | # Write the current configuration out to the file whose name is |
||
| 1214 | # given as an argument. The current configuration is stored in |
||
| 1215 | # global variables. |
||
| 1216 | # |
||
| 1217 | # If an error occurs (such as we can't open the output file) |
||
| 1218 | # generate an error. |
||
| 1219 | # |
||
| 1220 | proc WriteConfig {filename} { |
||
| 1221 | if {[catch {open $filename w} f]} { |
||
| 1222 | error "can't open $filename: $f" |
||
| 1223 | } |
||
| 1224 | puts $f "# Configuration file generated by xmktclapp" |
||
| 1225 | puts $f "# Hand editing is not recommended" |
||
| 1226 | puts $f "#" |
||
| 1227 | puts $f "# The \"xmktclapp\" program reads the lines that begin with \"##\"." |
||
| 1228 | puts $f "# The \"mktclapp\" program reads lines that don't begin with \"#\"." |
||
| 1229 | puts $f "# Lines beginning with a single \"#\" are comment." |
||
| 1230 | puts $f "#" |
||
| 1231 | |||
| 1232 | # Write the part that xmktclapp uses |
||
| 1233 | # |
||
| 1234 | global conf |
||
| 1235 | foreach v [lsort [array names conf]] { |
||
| 1236 | puts $f "## $v [list $conf($v)]" |
||
| 1237 | } |
||
| 1238 | puts $f "#" |
||
| 1239 | |||
| 1240 | # Write the part that mktclapp uses |
||
| 1241 | # |
||
| 1242 | set isExt 0 |
||
| 1243 | switch $conf(Mode) { |
||
| 1244 | {Tcl Only} { |
||
| 1245 | puts $f "-notk" |
||
| 1246 | } |
||
| 1247 | Extension { |
||
| 1248 | if {[info exists conf(OutputFile)] && $conf(OutputFile)!=""} { |
||
| 1249 | set fnm $conf(OutputFile) |
||
| 1250 | } else { |
||
| 1251 | set fnm $filename |
||
| 1252 | } |
||
| 1253 | set enm1 [file tail [file rootname $fnm]] |
||
| 1254 | set enm2 [string toupper [string index $enm1 0]] |
||
| 1255 | append enm2 [string tolower [string range $enm1 1 end]] |
||
| 1256 | puts $f "-extension $enm2" |
||
| 1257 | set isExt 1 |
||
| 1258 | } |
||
| 1259 | } |
||
| 1260 | if {!$isExt} { |
||
| 1261 | if {$conf(Autofork)=="Yes"} { |
||
| 1262 | puts $f "-autofork" |
||
| 1263 | } |
||
| 1264 | if {$conf(CmdLine)=="Console"} { |
||
| 1265 | puts $f "-console" |
||
| 1266 | } elseif {$conf(CmdLine)=="Stdin"} { |
||
| 1267 | puts $f "-read-stdin" |
||
| 1268 | } |
||
| 1269 | if {$conf(Standalone)=="Strict"} { |
||
| 1270 | puts $f "-standalone" |
||
| 1271 | } |
||
| 1272 | } |
||
| 1273 | if {$conf(Shroud)=="Yes"} { |
||
| 1274 | puts $f "-shroud" |
||
| 1275 | } |
||
| 1276 | if {[string length $conf(MainScript)]>0} { |
||
| 1277 | puts $f "-main-script \"$conf(MainScript)\"" |
||
| 1278 | } |
||
| 1279 | if {$conf(Standalone)!="No"} { |
||
| 1280 | set filelist {} |
||
| 1281 | if {!$isExt} { |
||
| 1282 | set filelist [glob -nocomplain $conf(TclLib)/*.tcl] |
||
| 1283 | if {[file exists $conf(TclLib)/tclIndex]} { |
||
| 1284 | lappend filelist $conf(TclLib)/tclIndex |
||
| 1285 | } |
||
| 1286 | # foreach file [glob -nocomplain $conf(TclLib)/*/*.tcl] { |
||
| 1287 | # lappend filelist $file |
||
| 1288 | # } |
||
| 1289 | puts $f "-tcl-library \"$conf(TclLib)\"" |
||
| 1290 | if {$conf(Mode)=="Tcl/Tk"} { |
||
| 1291 | set l2 [glob -nocomplain $conf(TkLib)/*.tcl] |
||
| 1292 | set filelist [concat $filelist $l2] |
||
| 1293 | if {[file exists $conf(TkLib)/tclIndex]} { |
||
| 1294 | lappend filelist $conf(TkLib)/tclIndex |
||
| 1295 | } |
||
| 1296 | puts $f "-tk-library \"$conf(TkLib)\"" |
||
| 1297 | } |
||
| 1298 | } |
||
| 1299 | set suffixes {.tcl .tk .itcl .itk .fs .fsc .cs .csc} |
||
| 1300 | foreach lib [array names conf OtherLib:*] { |
||
| 1301 | set lib [string range $lib 9 end] |
||
| 1302 | foreach file [glob -nocomplain $lib/*] { |
||
| 1303 | if {![file isfile $file]} continue |
||
| 1304 | if {[lsearch $suffixes [string tolower [file ext $file]]]<0} continue |
||
| 1305 | lappend filelist $file |
||
| 1306 | } |
||
| 1307 | if {[file exists $lib/tclIndex]} { |
||
| 1308 | lappend filelist $lib/tclIndex |
||
| 1309 | } |
||
| 1310 | } |
||
| 1311 | foreach file [lsort $filelist] { |
||
| 1312 | puts $f "-strip-tcl \"$file\"" |
||
| 1313 | } |
||
| 1314 | } |
||
| 1315 | foreach file [lsort [array names conf CFile:*]] { |
||
| 1316 | set fn [string range $file 6 end] |
||
| 1317 | puts $f \"$fn\" |
||
| 1318 | } |
||
| 1319 | foreach file [lsort [array names conf Data:*]] { |
||
| 1320 | set fn [string range $file 5 end] |
||
| 1321 | puts $f "-i \"$fn\"" |
||
| 1322 | } |
||
| 1323 | set tclFileList [lsort [array names conf TclFile:*]] |
||
| 1324 | foreach file $tclFileList { |
||
| 1325 | set fn [string range $file 8 end] |
||
| 1326 | if {$conf(TclFile:$fn)} { |
||
| 1327 | puts $f "-strip-tcl \"$fn\"" |
||
| 1328 | } else { |
||
| 1329 | puts $f "-dont-strip-tcl \"$fn\"" |
||
| 1330 | } |
||
| 1331 | } |
||
| 1332 | close $f |
||
| 1333 | Baseline |
||
| 1334 | } |
||
| 1335 | |||
| 1336 | # This routine does the work of the "Save" action. |
||
| 1337 | # |
||
| 1338 | proc DoSave {} { |
||
| 1339 | global conf |
||
| 1340 | if {[string length $conf(ConfigFile)]==0} { |
||
| 1341 | return [DoSaveAs] |
||
| 1342 | } |
||
| 1343 | set ext [file extension $conf(ConfigFile)] |
||
| 1344 | if {[string length $ext]==0} { |
||
| 1345 | set conf(ConfigFile) $conf(ConfigFile).mta |
||
| 1346 | } |
||
| 1347 | return [catch {WriteConfig $conf(ConfigFile)}] |
||
| 1348 | } |
||
| 1349 | |||
| 1350 | # This routine does the work of the "Save As..." action. |
||
| 1351 | # |
||
| 1352 | proc DoSaveAs {} { |
||
| 1353 | global conf initdir |
||
| 1354 | set types { |
||
| 1355 | {{Mktclapp Config Files} {.mta}} |
||
| 1356 | {{All Files} *} |
||
| 1357 | } |
||
| 1358 | set f [tk_getSaveFile -filetypes $types -defaultextension .mta \ |
||
| 1359 | -initialdir $initdir] |
||
| 1360 | if {$f!=""} { |
||
| 1361 | set initdir [file dirname $f] |
||
| 1362 | set f [RelativePath $f] |
||
| 1363 | set conf(ConfigFile) $f |
||
| 1364 | return [DoSave] |
||
| 1365 | } |
||
| 1366 | return 0 |
||
| 1367 | } |
||
| 1368 | |||
| 1369 | # Read state information from a named file. Return the number of |
||
| 1370 | # errors encountered. If the second parameter is not 0, then issue |
||
| 1371 | # an error message for each error found. |
||
| 1372 | # |
||
| 1373 | proc ReadState {fn {quiet 0}} { |
||
| 1374 | if {[catch {open $fn r} f]} { |
||
| 1375 | if {!$quiet} { |
||
| 1376 | tk_messageBox -message "Can't open \"$fn\": $f" -type ok -icon error |
||
| 1377 | } |
||
| 1378 | return 1 |
||
| 1379 | } |
||
| 1380 | set text [read $f] |
||
| 1381 | close $f |
||
| 1382 | SetDefaults |
||
| 1383 | global conf |
||
| 1384 | foreach line [split $text \n] { |
||
| 1385 | if {![regexp {^## } $line]} continue |
||
| 1386 | if {[lindex $line 0]!="##"} continue |
||
| 1387 | set var [lindex $line 1] |
||
| 1388 | set value [lindex $line 2] |
||
| 1389 | set conf($var) $value |
||
| 1390 | } |
||
| 1391 | set conf(ConfigFile) $fn |
||
| 1392 | if {![info exists conf(OutputFile)] || [string length $conf(OutputFile)]==0} { |
||
| 1393 | set conf(OutputFile) [file root $conf(ConfigFile)].c |
||
| 1394 | } |
||
| 1395 | InsertC |
||
| 1396 | InsertTcl |
||
| 1397 | InsertData |
||
| 1398 | FillOtherLib |
||
| 1399 | return 0 |
||
| 1400 | } |
||
| 1401 | |||
| 1402 | # This routine does the work of the Open action. |
||
| 1403 | # |
||
| 1404 | proc DoOpen {} { |
||
| 1405 | global conf initdir |
||
| 1406 | set types { |
||
| 1407 | {{Mktclapp Config Files} {.mta}} |
||
| 1408 | {{All Files} *} |
||
| 1409 | } |
||
| 1410 | set f [tk_getOpenFile -filetypes $types -defaultextension .mta \ |
||
| 1411 | -initialdir $initdir] |
||
| 1412 | if {$f==""} return |
||
| 1413 | set initdir [file dirname $f] |
||
| 1414 | set f [RelativePath $f] |
||
| 1415 | set conf(ConfigFile) $f |
||
| 1416 | ReadState $conf(ConfigFile) |
||
| 1417 | Baseline |
||
| 1418 | } |
||
| 1419 | set initdir [pwd] |
||
| 1420 | |||
| 1421 | # Compare the current configuration with the configuration that |
||
| 1422 | # we read from disk. Return 1 if we need to save to disk. |
||
| 1423 | # |
||
| 1424 | proc IsDirty {} { |
||
| 1425 | global conf saved |
||
| 1426 | |||
| 1427 | foreach v [array names conf] { |
||
| 1428 | if {![info exists saved($v)] || [string compare $conf($v) $saved($v)]} { |
||
| 1429 | return 1 |
||
| 1430 | } |
||
| 1431 | } |
||
| 1432 | foreach v [array names saved] { |
||
| 1433 | if {![info exists conf($v)]} { |
||
| 1434 | return 1 |
||
| 1435 | } |
||
| 1436 | } |
||
| 1437 | return 0 |
||
| 1438 | } |
||
| 1439 | |||
| 1440 | # We currently are not dirty. Remember the current state of |
||
| 1441 | # everything so we can compare it later to see if anything has |
||
| 1442 | # changed. |
||
| 1443 | # |
||
| 1444 | proc Baseline {} { |
||
| 1445 | global conf saved |
||
| 1446 | catch {unset saved} |
||
| 1447 | foreach v [array names conf] { |
||
| 1448 | set saved($v) $conf($v) |
||
| 1449 | } |
||
| 1450 | } |
||
| 1451 | |||
| 1452 | # Make the current configuration dirty by clearing all the |
||
| 1453 | # "saved()" variables. |
||
| 1454 | # |
||
| 1455 | proc MakeDirty {} { |
||
| 1456 | catch {unset saved} |
||
| 1457 | } |
||
| 1458 | |||
| 1459 | # Exit the GUI, after first saving the state |
||
| 1460 | # |
||
| 1461 | proc DoExit {} { |
||
| 1462 | if {[IsDirty]} { |
||
| 1463 | set r [tk_messageBox -message "Save changes before exiting?" \ |
||
| 1464 | -type yesnocancel] |
||
| 1465 | if {$r=="cancel"} return |
||
| 1466 | if {$r=="yes"} { |
||
| 1467 | if {[DoSave]} return |
||
| 1468 | } |
||
| 1469 | } |
||
| 1470 | exit |
||
| 1471 | } |
||
| 1472 | |||
| 1473 | # Initialize the application to its default state. |
||
| 1474 | # |
||
| 1475 | proc SetDefaults {} { |
||
| 1476 | global conf tcl_library tk_library |
||
| 1477 | foreach v [array names conf *File:*] {unset conf($v)} |
||
| 1478 | foreach v [array names conf OtherLib:*] {unset conf($v)} |
||
| 1479 | set conf(Mode) Tcl/Tk |
||
| 1480 | set conf(Autofork) No |
||
| 1481 | set conf(Standalone) No |
||
| 1482 | set conf(NoSource) No |
||
| 1483 | set conf(ConfigFile) appinit.mta |
||
| 1484 | set conf(Shroud) No |
||
| 1485 | set conf(MainScript) {} |
||
| 1486 | set conf(TclLib) $tcl_library |
||
| 1487 | set conf(TkLib) $tk_library |
||
| 1488 | } |
||
| 1489 | |||
| 1490 | # Try to convert a full pathname into a relative pathname. |
||
| 1491 | # But do the convertion only if no ".." are required up front. |
||
| 1492 | # |
||
| 1493 | proc RelativePath {full} { |
||
| 1494 | if {[file pathtype $full]=="absolute"} { |
||
| 1495 | set pwd [string trimright [pwd] /] |
||
| 1496 | set len [string length $pwd] |
||
| 1497 | set path [string range $full 0 $len] |
||
| 1498 | if {[string compare $path $pwd/]==0} { |
||
| 1499 | set full [string range $full [expr $len+1] end] |
||
| 1500 | } |
||
| 1501 | } |
||
| 1502 | return $full |
||
| 1503 | } |
||
| 1504 | |||
| 1505 | # Force a filename to be relative to the current working directory. |
||
| 1506 | # ".." are inserted if needed. |
||
| 1507 | # |
||
| 1508 | proc ForceRelative {name} { |
||
| 1509 | switch [file pathtype $name] { |
||
| 1510 | absolute { |
||
| 1511 | set pwd [file split [pwd]] |
||
| 1512 | set path [file split $name] |
||
| 1513 | global tcl_platform |
||
| 1514 | if {$tcl_platform(platform)=="windows"} { |
||
| 1515 | set pwd [string tolower $pwd] |
||
| 1516 | set path [string tolower $path] |
||
| 1517 | } |
||
| 1518 | set npwd [llength $pwd] |
||
| 1519 | set npath [llength $path] |
||
| 1520 | for {set i 0} {$i<$npwd && $i<$npath} {incr i} { |
||
| 1521 | if {[string compare [lindex $pwd $i] [lindex $path $i]]} break |
||
| 1522 | } |
||
| 1523 | set res {} |
||
| 1524 | for {set j 0} {$j<$npwd-$i} {incr j} { |
||
| 1525 | lappend res .. |
||
| 1526 | } |
||
| 1527 | set res [concat $res [lrange $path $i end]] |
||
| 1528 | if {[llength $res]==0} { |
||
| 1529 | return "." |
||
| 1530 | } |
||
| 1531 | return [eval file join $res] |
||
| 1532 | } |
||
| 1533 | relative - |
||
| 1534 | volumerelative { |
||
| 1535 | return $name |
||
| 1536 | } |
||
| 1537 | } |
||
| 1538 | } |
||
| 1539 | |||
| 1540 | # Force a filename to be absolute. |
||
| 1541 | # |
||
| 1542 | proc ForceAbsolute {name} { |
||
| 1543 | switch [file pathtype $name] { |
||
| 1544 | relative { |
||
| 1545 | set path [file split [pwd]/$name] |
||
| 1546 | set len [llength $path] |
||
| 1547 | for {set i 1} {$i<$len} {incr i} { |
||
| 1548 | set dir [lindex $path $i] |
||
| 1549 | if {$dir=="."} { |
||
| 1550 | set path [lreplace $path $i $i] |
||
| 1551 | incr i -1 |
||
| 1552 | incr len -1 |
||
| 1553 | continue |
||
| 1554 | } |
||
| 1555 | if {$dir==".."} { |
||
| 1556 | if {$i==1} { |
||
| 1557 | set path [lreplace $path $i $i] |
||
| 1558 | incr i -1 |
||
| 1559 | incr len -1 |
||
| 1560 | } else { |
||
| 1561 | set path [lreplace $path [expr $i-1] $i] |
||
| 1562 | incr i -2 |
||
| 1563 | incr len -2 |
||
| 1564 | } |
||
| 1565 | continue |
||
| 1566 | } |
||
| 1567 | } |
||
| 1568 | return [eval file join $path] |
||
| 1569 | } |
||
| 1570 | absolute { |
||
| 1571 | return $name |
||
| 1572 | } |
||
| 1573 | volumerelative { |
||
| 1574 | return $name |
||
| 1575 | } |
||
| 1576 | } |
||
| 1577 | } |
||
| 1578 | |||
| 1579 | # Change a relative path to absolute and an absolute path to relative. |
||
| 1580 | # |
||
| 1581 | proc TogglePath {path} { |
||
| 1582 | switch [file pathtype $path] { |
||
| 1583 | absolute { |
||
| 1584 | return [ForceRelative $path] |
||
| 1585 | } |
||
| 1586 | relative { |
||
| 1587 | return [ForceAbsolute $path] |
||
| 1588 | } |
||
| 1589 | volumerelative { |
||
| 1590 | return $path |
||
| 1591 | } |
||
| 1592 | } |
||
| 1593 | } |
||
| 1594 | |||
| 1595 | # This routine is called to when various "Relative Path" buttons |
||
| 1596 | # are pressed. $w is the button widget. $var is the name of the |
||
| 1597 | # variable that contains the pathname that needs to be toggled |
||
| 1598 | # between relative and absolute. |
||
| 1599 | # |
||
| 1600 | proc RelAbsPath {w var} { |
||
| 1601 | upvar #0 $var path |
||
| 1602 | set path [TogglePath $path] |
||
| 1603 | ConfigPathButton $w $path |
||
| 1604 | } |
||
| 1605 | |||
| 1606 | # This routine works like RelAbsPath above, but for the special |
||
| 1607 | # case of the Startup Script on the Tcl Scripts page. In addition |
||
| 1608 | # to toggling the path of the Startup Script (in conf(MainScript)) |
||
| 1609 | # we check to see if the script is in the list of Tcl scripts and |
||
| 1610 | # toggle its name there too. |
||
| 1611 | # |
||
| 1612 | proc MainScriptChngPath {w} { |
||
| 1613 | global conf |
||
| 1614 | set old $conf(MainScript) |
||
| 1615 | RelAbsPath $w conf(MainScript) |
||
| 1616 | set new $conf(MainScript) |
||
| 1617 | if {[info exists conf(TclFile:$old)] && [string compare $new $old]} { |
||
| 1618 | set conf(TclFile:$new) $conf(TclFile:$old) |
||
| 1619 | unset conf(TclFile:$old) |
||
| 1620 | InsertTcl |
||
| 1621 | } |
||
| 1622 | } |
||
| 1623 | |||
| 1624 | # Given a pathname and a button widget, set the button widget depending |
||
| 1625 | # on the pathname. As follows: |
||
| 1626 | # |
||
| 1627 | # 1. If the pathname is NULL, disable the button. |
||
| 1628 | # |
||
| 1629 | # 2. If the pathname is a relative path, make the button read |
||
| 1630 | # "Absolute Path". |
||
| 1631 | # |
||
| 1632 | # 3. If the pathname is absolute, make the button read "Relative Path". |
||
| 1633 | # |
||
| 1634 | proc ConfigPathButton {w path} { |
||
| 1635 | if {[string length $path]==0} { |
||
| 1636 | $w config -state disabled -text {Rel/Abs Path} |
||
| 1637 | } else { |
||
| 1638 | switch [file pathtype $path] { |
||
| 1639 | relative { |
||
| 1640 | $w config -state normal -text {Absolute Path} |
||
| 1641 | } |
||
| 1642 | absolute { |
||
| 1643 | $w config -state normal -text {Relative Path} |
||
| 1644 | } |
||
| 1645 | volumerelative { |
||
| 1646 | $w config -state disabled -text {} |
||
| 1647 | } |
||
| 1648 | } |
||
| 1649 | } |
||
| 1650 | } |
||
| 1651 | |||
| 1652 | # This routine allows ConfigPathButton to be called from a |
||
| 1653 | # variable trace. |
||
| 1654 | # |
||
| 1655 | proc TracePath {w var args} { |
||
| 1656 | global conf |
||
| 1657 | ConfigPathButton $w [set $var] |
||
| 1658 | } |
||
| 1659 | |||
| 1660 | # Insert all the files named in the CFile array into the |
||
| 1661 | # listbox on the C/C++ modules page |
||
| 1662 | # |
||
| 1663 | proc InsertC {{sel {}}} { |
||
| 1664 | global conf |
||
| 1665 | set w [Notebook:frame .n {C/C++ Modules}] |
||
| 1666 | $w.c.lb delete 0 end |
||
| 1667 | set idx 0 |
||
| 1668 | foreach i [lsort [array names conf CFile:*]] { |
||
| 1669 | set fn [string range $i 6 end] |
||
| 1670 | $w.c.lb insert end $fn |
||
| 1671 | if {[string compare $sel $fn]==0} { |
||
| 1672 | $w.c.lb select clear 0 end |
||
| 1673 | $w.c.lb select set $idx |
||
| 1674 | } |
||
| 1675 | incr idx |
||
| 1676 | } |
||
| 1677 | SetCSelect |
||
| 1678 | } |
||
| 1679 | |||
| 1680 | # Insert all the files named in the Data array into the |
||
| 1681 | # listbox on the Data Files page |
||
| 1682 | # |
||
| 1683 | proc InsertData {{sel {}}} { |
||
| 1684 | global conf |
||
| 1685 | set w [Notebook:frame .n {Data Files}] |
||
| 1686 | $w.c.lb delete 0 end |
||
| 1687 | set idx 0 |
||
| 1688 | foreach i [lsort [array names conf Data:*]] { |
||
| 1689 | set fn [string range $i 5 end] |
||
| 1690 | $w.c.lb insert end $fn |
||
| 1691 | if {[string compare $sel $fn]==0} { |
||
| 1692 | $w.c.lb select clear 0 end |
||
| 1693 | $w.c.lb select set $idx |
||
| 1694 | } |
||
| 1695 | incr idx |
||
| 1696 | } |
||
| 1697 | SetDataSelect |
||
| 1698 | } |
||
| 1699 | |||
| 1700 | # Insert all the files named in the TclFile array into the |
||
| 1701 | # listbox on the Tcl Scripts page. |
||
| 1702 | # |
||
| 1703 | proc InsertTcl {{sel {}}} { |
||
| 1704 | global conf |
||
| 1705 | set w [Notebook:frame .n {Tcl Scripts}] |
||
| 1706 | $w.c.lb delete 0 end |
||
| 1707 | set idx 0 |
||
| 1708 | foreach i [lsort [array names conf TclFile:*]] { |
||
| 1709 | set fn [string range $i 8 end] |
||
| 1710 | if {$conf($i)} { |
||
| 1711 | set x "* $fn" |
||
| 1712 | } else { |
||
| 1713 | set x " $fn" |
||
| 1714 | } |
||
| 1715 | $w.c.lb insert end $x |
||
| 1716 | if {[string compare $sel $fn]==0} { |
||
| 1717 | $w.c.lb select clear 0 end |
||
| 1718 | $w.c.lb select set $idx |
||
| 1719 | } |
||
| 1720 | incr idx |
||
| 1721 | } |
||
| 1722 | SetTclSelect |
||
| 1723 | } |
||
| 1724 | |||
| 1725 | # This routine runs when the user presses the "Insert" button |
||
| 1726 | # on the C/C++ Modules page |
||
| 1727 | # |
||
| 1728 | proc DoInsertC {} { |
||
| 1729 | set types { |
||
| 1730 | {{C/C++ Source} {.c .cpp .cc .C}} |
||
| 1731 | } |
||
| 1732 | global initdir |
||
| 1733 | set f [tk_getOpenFile -filetypes $types \ |
||
| 1734 | -title {Select C/C++ source} -initialdir $initdir] |
||
| 1735 | if {[string length $f]>0} { |
||
| 1736 | set initdir [file dirname $f] |
||
| 1737 | set f [RelativePath $f] |
||
| 1738 | global conf |
||
| 1739 | set conf(CFile:$f) 1 |
||
| 1740 | InsertC |
||
| 1741 | } |
||
| 1742 | } |
||
| 1743 | |||
| 1744 | # This routine runs when the user presses the "Insert" button |
||
| 1745 | # on the Data Files page |
||
| 1746 | # |
||
| 1747 | proc DoInsertData {} { |
||
| 1748 | set types { |
||
| 1749 | {{All files} *} |
||
| 1750 | } |
||
| 1751 | global initdir |
||
| 1752 | set f [tk_getOpenFile -filetypes $types \ |
||
| 1753 | -title {Select Data File} -initialdir $initdir] |
||
| 1754 | if {[string length $f]>0} { |
||
| 1755 | set initdir [file dirname $f] |
||
| 1756 | set f [RelativePath $f] |
||
| 1757 | global conf |
||
| 1758 | set conf(Data:$f) 1 |
||
| 1759 | InsertData |
||
| 1760 | } |
||
| 1761 | } |
||
| 1762 | |||
| 1763 | # This routine runs when the user presses the "Insert" button |
||
| 1764 | # on the Tcl Scripts page |
||
| 1765 | # |
||
| 1766 | proc DoInsertTcl {} { |
||
| 1767 | set types { |
||
| 1768 | {{Tcl Scripts} {.tcl}} |
||
| 1769 | {{All Files} *} |
||
| 1770 | } |
||
| 1771 | global initdir |
||
| 1772 | set f [tk_getOpenFile -filetypes $types -title {Select Tcl Script} \ |
||
| 1773 | -initialdir $initdir] |
||
| 1774 | if {[string length $f]>0} { |
||
| 1775 | set initdir [file dirname $f] |
||
| 1776 | set f [RelativePath $f] |
||
| 1777 | global conf |
||
| 1778 | set conf(TclFile:$f) 1 |
||
| 1779 | InsertTcl |
||
| 1780 | } |
||
| 1781 | } |
||
| 1782 | |||
| 1783 | # This routine runs when the user presses the "Browse" button on |
||
| 1784 | # the Output C File entry box. |
||
| 1785 | # |
||
| 1786 | proc BrowseForOutputFile {} { |
||
| 1787 | set types { |
||
| 1788 | {{C/C++ Source Files} {.c .C}} |
||
| 1789 | {{All Files} *} |
||
| 1790 | } |
||
| 1791 | global initdir |
||
| 1792 | set f [tk_getSaveFile -filetypes $types -title {Select Output File} \ |
||
| 1793 | -initialdir $initdir] |
||
| 1794 | if {[string length $f]>0} { |
||
| 1795 | set initdir [file dirname $f] |
||
| 1796 | set f [RelativePath $f] |
||
| 1797 | global conf |
||
| 1798 | set conf(OutputFile) $f |
||
| 1799 | } |
||
| 1800 | } |
||
| 1801 | |||
| 1802 | # This routine runs when the user presses the "Browse" button on |
||
| 1803 | # the Tcl Scripts page |
||
| 1804 | # |
||
| 1805 | proc BrowseForMainScript {} { |
||
| 1806 | set types { |
||
| 1807 | {{Tcl Scripts} {.tcl}} |
||
| 1808 | {{All Files} *} |
||
| 1809 | } |
||
| 1810 | global initdir |
||
| 1811 | set f [tk_getOpenFile -filetypes $types -title {Select Tcl Script} \ |
||
| 1812 | -initialdir $initdir] |
||
| 1813 | if {[string length $f]>0} { |
||
| 1814 | set initdir [file dirname $f] |
||
| 1815 | set f [RelativePath $f] |
||
| 1816 | global conf |
||
| 1817 | set conf(MainScript) $f |
||
| 1818 | } |
||
| 1819 | } |
||
| 1820 | |||
| 1821 | # This routine runs when the user presses the "Browse" button beside |
||
| 1822 | # The Tcl Library entry box. We want to select the directory that |
||
| 1823 | # contains the Tcl Script library. |
||
| 1824 | # |
||
| 1825 | proc BrowseForTclLib {} { |
||
| 1826 | global conf |
||
| 1827 | set f [tk_getDirectory -initialdir $conf(TclLib) -title "Tcl Script Library"] |
||
| 1828 | if {[string length $f]>0} { |
||
| 1829 | set conf(TclLib) $f |
||
| 1830 | } |
||
| 1831 | } |
||
| 1832 | |||
| 1833 | # This routine runs when the user presses the "Browse" button beside |
||
| 1834 | # The Tk Library entry box. We want to select the directory that |
||
| 1835 | # contains the Tk Script library. |
||
| 1836 | # |
||
| 1837 | proc BrowseForTkLib {} { |
||
| 1838 | global conf |
||
| 1839 | set f [tk_getDirectory -initialdir $conf(TkLib) -title "Tk Script Library"] |
||
| 1840 | if {[string length $f]>0} { |
||
| 1841 | set conf(TkLib) $f |
||
| 1842 | } |
||
| 1843 | } |
||
| 1844 | |||
| 1845 | # After the user clicks in the listbox on the Libraries page, |
||
| 1846 | # this routine runs to update the screen according to what is |
||
| 1847 | # selected. |
||
| 1848 | # |
||
| 1849 | proc SetOtherLibSelect {} { |
||
| 1850 | global widget |
||
| 1851 | set f3 $widget(OtherLib) |
||
| 1852 | set s [$f3.lb cursel] |
||
| 1853 | if {[llength $s]>0} { |
||
| 1854 | $f3.b.del config -state normal |
||
| 1855 | set fn [$f3.lb get [lindex $s 0]] |
||
| 1856 | } else { |
||
| 1857 | $f3.b.del config -state disabled |
||
| 1858 | set fn {} |
||
| 1859 | } |
||
| 1860 | ConfigPathButton $f3.b.rp $fn |
||
| 1861 | } |
||
| 1862 | |||
| 1863 | # This routine runs when the user presses the "Delete" button on |
||
| 1864 | # the Libraries page in the "Other Libraries" frame. |
||
| 1865 | # |
||
| 1866 | proc DoDeleteOtherLib {} { |
||
| 1867 | global widget |
||
| 1868 | set f3 $widget(OtherLib) |
||
| 1869 | set s [$f3.lb cursel] |
||
| 1870 | global conf |
||
| 1871 | foreach i $s { |
||
| 1872 | set dir [$f3.lb get $i] |
||
| 1873 | catch {unset conf(OtherLib:$dir)} |
||
| 1874 | $f3.lb delete $i |
||
| 1875 | } |
||
| 1876 | SetOtherLibSelect |
||
| 1877 | } |
||
| 1878 | |||
| 1879 | # This routine runs when the user presses the "Insert" button beside |
||
| 1880 | # The Other Library entry box. We want select a directory to add |
||
| 1881 | # to the list box. |
||
| 1882 | # |
||
| 1883 | proc DoInsertOtherLib {} { |
||
| 1884 | global conf |
||
| 1885 | set f [tk_getDirectory -title "Script Library"] |
||
| 1886 | if {[string length $f]>0} { |
||
| 1887 | set conf(OtherLib:$f) 1 |
||
| 1888 | } |
||
| 1889 | FillOtherLib $f |
||
| 1890 | } |
||
| 1891 | |||
| 1892 | # Look at the conf(OtherLib:*) entries and fill the Other Libraries |
||
| 1893 | # list box accordingly. |
||
| 1894 | # |
||
| 1895 | proc FillOtherLib {{sel {}}} { |
||
| 1896 | global conf widget |
||
| 1897 | set f3 $widget(OtherLib) |
||
| 1898 | $f3.lb delete 0 end |
||
| 1899 | set idx 0 |
||
| 1900 | foreach i [lsort [array names conf OtherLib:*]] { |
||
| 1901 | set fn [string range $i 9 end] |
||
| 1902 | $f3.lb insert end $fn |
||
| 1903 | if {[string compare $sel $fn]==0} { |
||
| 1904 | $f3.lb select clear 0 end |
||
| 1905 | $f3.lb select set $idx |
||
| 1906 | } |
||
| 1907 | incr idx |
||
| 1908 | } |
||
| 1909 | SetOtherLibSelect |
||
| 1910 | } |
||
| 1911 | |||
| 1912 | # After the user clicks in the listbox on the C/C++ Modules page, |
||
| 1913 | # this routine runs to update the screen according to what is |
||
| 1914 | # selected. |
||
| 1915 | # |
||
| 1916 | proc SetCSelect {} { |
||
| 1917 | set w [Notebook:frame .n {C/C++ Modules}] |
||
| 1918 | set s [$w.c.lb cursel] |
||
| 1919 | if {[llength $s]>0} { |
||
| 1920 | $w.b.del config -state normal |
||
| 1921 | set fn [$w.c.lb get [lindex $s 0]] |
||
| 1922 | } else { |
||
| 1923 | $w.b.del config -state disabled |
||
| 1924 | set fn {} |
||
| 1925 | } |
||
| 1926 | ConfigPathButton $w.b.rp $fn |
||
| 1927 | } |
||
| 1928 | |||
| 1929 | # After the user clicks in the listbox on the Data Files page, |
||
| 1930 | # This routine runs to update the screen according to what is |
||
| 1931 | # selected. |
||
| 1932 | # |
||
| 1933 | proc SetDataSelect {} { |
||
| 1934 | set w [Notebook:frame .n {Data Files}] |
||
| 1935 | set s [$w.c.lb cursel] |
||
| 1936 | if {[llength $s]>0} { |
||
| 1937 | $w.b.del config -state normal |
||
| 1938 | set fn [$w.c.lb get [lindex $s 0]] |
||
| 1939 | } else { |
||
| 1940 | $w.b.del config -state disabled |
||
| 1941 | set fn {} |
||
| 1942 | } |
||
| 1943 | ConfigPathButton $w.b.rp $fn |
||
| 1944 | } |
||
| 1945 | |||
| 1946 | # This routine runs when the user presses the "Delete" button on |
||
| 1947 | # the C/C++ Modules page. |
||
| 1948 | # |
||
| 1949 | proc DoDeleteC {} { |
||
| 1950 | set w [Notebook:frame .n {C/C++ Modules}] |
||
| 1951 | set s [$w.c.lb cursel] |
||
| 1952 | global conf |
||
| 1953 | foreach i $s { |
||
| 1954 | set file [$w.c.lb get $i] |
||
| 1955 | catch {unset conf(CFile:$file)} |
||
| 1956 | $w.c.lb delete $i |
||
| 1957 | } |
||
| 1958 | SetCSelect |
||
| 1959 | } |
||
| 1960 | |||
| 1961 | # This routine runs when the user presses the "Delete" button on |
||
| 1962 | # the Data Files page. |
||
| 1963 | # |
||
| 1964 | proc DoDeleteData {} { |
||
| 1965 | set w [Notebook:frame .n {Data Files}] |
||
| 1966 | set s [$w.c.lb cursel] |
||
| 1967 | global conf |
||
| 1968 | foreach i $s { |
||
| 1969 | set file [$w.c.lb get $i] |
||
| 1970 | catch {unset conf(Data:$file)} |
||
| 1971 | $w.c.lb delete $i |
||
| 1972 | } |
||
| 1973 | SetDataSelect |
||
| 1974 | } |
||
| 1975 | |||
| 1976 | # This routine runs when the user presses the "Relative Path" or |
||
| 1977 | # "Absolute Path" button associated with the list of C/C++ Modules |
||
| 1978 | # |
||
| 1979 | proc CChngPath {} { |
||
| 1980 | set w [Notebook:frame .n {C/C++ Modules}] |
||
| 1981 | set s [$w.c.lb cursel] |
||
| 1982 | global conf |
||
| 1983 | set new {} |
||
| 1984 | foreach i $s { |
||
| 1985 | set file [$w.c.lb get $i] |
||
| 1986 | if {[info exists conf(CFile:$file)]} { |
||
| 1987 | set new [TogglePath $file] |
||
| 1988 | if {[string compare $new $file]} { |
||
| 1989 | set conf(CFile:$new) $conf(CFile:$file) |
||
| 1990 | unset conf(CFile:$file) |
||
| 1991 | } |
||
| 1992 | } |
||
| 1993 | } |
||
| 1994 | InsertC $new |
||
| 1995 | } |
||
| 1996 | |||
| 1997 | # This routine runs when the user presses the "Relative Path" or |
||
| 1998 | # "Absolute Path" button associated with the list of Data files |
||
| 1999 | # |
||
| 2000 | proc DataChngPath {} { |
||
| 2001 | set w [Notebook:frame .n {Data Files}] |
||
| 2002 | set s [$w.c.lb cursel] |
||
| 2003 | global conf |
||
| 2004 | set new {} |
||
| 2005 | foreach i $s { |
||
| 2006 | set file [$w.c.lb get $i] |
||
| 2007 | if {[info exists conf(Data:$file)]} { |
||
| 2008 | set new [TogglePath $file] |
||
| 2009 | if {[string compare $new $file]} { |
||
| 2010 | set conf(Data:$new) $conf(Data:$file) |
||
| 2011 | unset conf(Data:$file) |
||
| 2012 | } |
||
| 2013 | } |
||
| 2014 | } |
||
| 2015 | InsertData $new |
||
| 2016 | } |
||
| 2017 | |||
| 2018 | # After the user clicks in the listbox on the Tcl Scripts page, |
||
| 2019 | # this routine runs to update the screen according to what is |
||
| 2020 | # selected. |
||
| 2021 | # |
||
| 2022 | proc SetTclSelect {} { |
||
| 2023 | set w [Notebook:frame .n {Tcl Scripts}] |
||
| 2024 | set s [$w.c.lb cursel] |
||
| 2025 | if {[llength $s]>0} { |
||
| 2026 | $w.b.del config -state normal |
||
| 2027 | $w.b.stc config -state normal |
||
| 2028 | set i [lindex $s 0] |
||
| 2029 | set f [string range [$w.c.lb get $i] 2 end] |
||
| 2030 | global conf |
||
| 2031 | if {$conf(TclFile:$f)} { |
||
| 2032 | $w.b.stc config -text {Don't Strip Comments} \ |
||
| 2033 | -command "DontStrip [list $f]" |
||
| 2034 | } else { |
||
| 2035 | $w.b.stc config -text {Do Strip Comments} \ |
||
| 2036 | -command "DoStrip [list $f]" |
||
| 2037 | } |
||
| 2038 | } else { |
||
| 2039 | $w.b.del config -state disabled |
||
| 2040 | $w.b.stc config -state disabled |
||
| 2041 | set f {} |
||
| 2042 | } |
||
| 2043 | ConfigPathButton $w.b2.rp $f |
||
| 2044 | } |
||
| 2045 | |||
| 2046 | # This routine runs when the user clicks on the "Don't Strip Comments" |
||
| 2047 | # button on the Tcl Scripts page. |
||
| 2048 | # |
||
| 2049 | proc DontStrip f { |
||
| 2050 | global conf |
||
| 2051 | set conf(TclFile:$f) 0 |
||
| 2052 | InsertTcl $f |
||
| 2053 | } |
||
| 2054 | |||
| 2055 | # This routine runs when the user clicks on the "Do Strip Comments" |
||
| 2056 | # button on the Tcl Scripts page. |
||
| 2057 | # |
||
| 2058 | proc DoStrip f { |
||
| 2059 | global conf |
||
| 2060 | set conf(TclFile:$f) 1 |
||
| 2061 | InsertTcl $f |
||
| 2062 | } |
||
| 2063 | |||
| 2064 | # This routine runs when the user presses the "Delete" button on |
||
| 2065 | # the Tcl Scripts page. |
||
| 2066 | # |
||
| 2067 | proc DoDeleteTcl {} { |
||
| 2068 | set w [Notebook:frame .n {Tcl Scripts}] |
||
| 2069 | set s [$w.c.lb cursel] |
||
| 2070 | global conf |
||
| 2071 | foreach i $s { |
||
| 2072 | set file [string range [$w.c.lb get $i] 2 end] |
||
| 2073 | catch {unset conf(TclFile:$file)} |
||
| 2074 | $w.c.lb delete $i |
||
| 2075 | } |
||
| 2076 | SetTclSelect |
||
| 2077 | } |
||
| 2078 | |||
| 2079 | # This routine runs when the user presses the "Relative Path" or |
||
| 2080 | # "Absolute Path" button associated with the list of Tcl Scripts. |
||
| 2081 | # |
||
| 2082 | proc TclChngPath {} { |
||
| 2083 | set w [Notebook:frame .n {Tcl Scripts}] |
||
| 2084 | set s [$w.c.lb cursel] |
||
| 2085 | global conf |
||
| 2086 | set new {} |
||
| 2087 | foreach i $s { |
||
| 2088 | set file [string range [$w.c.lb get $i] 2 end] |
||
| 2089 | if {[info exists conf(TclFile:$file)]} { |
||
| 2090 | set new [TogglePath $file] |
||
| 2091 | if {[string compare $new $file]} { |
||
| 2092 | set conf(TclFile:$new) $conf(TclFile:$file) |
||
| 2093 | unset conf(TclFile:$file) |
||
| 2094 | if {[string compare $file $conf(MainScript)]==0} { |
||
| 2095 | set conf(MainScript) $new |
||
| 2096 | } |
||
| 2097 | } |
||
| 2098 | } |
||
| 2099 | } |
||
| 2100 | InsertTcl $new |
||
| 2101 | } |
||
| 2102 | |||
| 2103 | # This routine runs when the user presses the "Relative Path" or |
||
| 2104 | # "Absolute Path" button associated with the list of Other Libraries. |
||
| 2105 | # |
||
| 2106 | proc OtherLibChngPath {} { |
||
| 2107 | global conf widget |
||
| 2108 | set f3 $widget(OtherLib) |
||
| 2109 | set s [$f3.lb cursel] |
||
| 2110 | set new {} |
||
| 2111 | foreach i $s { |
||
| 2112 | set dir [$f3.lb get $i] |
||
| 2113 | if {[info exists conf(OtherLib:$dir)]} { |
||
| 2114 | set new [TogglePath $dir] |
||
| 2115 | if {[string compare $new $dir]} { |
||
| 2116 | set conf(OtherLib:$new) $conf(OtherLib:$dir) |
||
| 2117 | unset conf(OtherLib:$dir) |
||
| 2118 | } |
||
| 2119 | } |
||
| 2120 | } |
||
| 2121 | FillOtherLib $new |
||
| 2122 | } |
||
| 2123 | |||
| 2124 | # Check for dubious information in the configuration parameters. |
||
| 2125 | # Report an error and return 1 if found. Return 0 if everything |
||
| 2126 | # looks ok. |
||
| 2127 | # |
||
| 2128 | proc CheckData {} { |
||
| 2129 | global conf |
||
| 2130 | set tclFileList [array names conf TclFile:*] |
||
| 2131 | set res 0 |
||
| 2132 | if {[llength $tclFileList]>0 && [string length $conf(MainScript)]==0} { |
||
| 2133 | set msg "No \"Startup\" Tcl Script Specified" |
||
| 2134 | set res [tk_messageBox -icon warning -message $msg -type okcancel] |
||
| 2135 | set res [string compare $res ok] |
||
| 2136 | } |
||
| 2137 | if {[string length $conf(MainScript)]>0 |
||
| 2138 | && [lsearch -exact $tclFileList TclFile:$conf(MainScript)]<0} { |
||
| 2139 | set msg "The \"Startup\" Tcl Script Is Not A Built-In Script!" |
||
| 2140 | set res [tk_messageBox -icon warning -message $msg -type okcancel] |
||
| 2141 | set res [string compare $res ok] |
||
| 2142 | } |
||
| 2143 | return $res |
||
| 2144 | } |
||
| 2145 | |||
| 2146 | # This routine runs when the "Build" button is pressed on the |
||
| 2147 | # Settings page. |
||
| 2148 | # |
||
| 2149 | proc DoBuild {} { |
||
| 2150 | if {[CheckData]} return |
||
| 2151 | DoSave |
||
| 2152 | set nerr 0 |
||
| 2153 | global conf |
||
| 2154 | if {![info exists conf(OutputFile)] || [string length $conf(OutputFile)]==0} { |
||
| 2155 | set conf(OutputFile) [file root $conf(ConfigFile)].c |
||
| 2156 | } |
||
| 2157 | set h [file root $conf(OutputFile)].h |
||
| 2158 | if {[catch {exec mktclapp -header >$h} msg]} { |
||
| 2159 | tk_messageBox -message "Error in command: $msg" \ |
||
| 2160 | -type ok -icon error -title {Error In Build} |
||
| 2161 | incr nerr |
||
| 2162 | } |
||
| 2163 | if {[catch {exec mktclapp -f $conf(ConfigFile) >$conf(OutputFile)} msg]} { |
||
| 2164 | tk_messageBox -message "Error in command: $msg" \ |
||
| 2165 | -type ok -icon error -title {Error In Build} |
||
| 2166 | incr nerr |
||
| 2167 | } |
||
| 2168 | if {$nerr==0} { |
||
| 2169 | set msg "Built \"$conf(OutputFile)\" and \"$h\" with " |
||
| 2170 | append msg "no errors." |
||
| 2171 | tk_messageBox -message $msg -type ok -icon info -title {Build Complete} |
||
| 2172 | } |
||
| 2173 | } |
||
| 2174 | |||
| 2175 | # This routine pops up a help dialog. The help topic is the |
||
| 2176 | # argument. |
||
| 2177 | # |
||
| 2178 | proc DoHelp subject { |
||
| 2179 | global Help |
||
| 2180 | if {[winfo exists .help]} { |
||
| 2181 | destroy .help |
||
| 2182 | } |
||
| 2183 | toplevel .help |
||
| 2184 | wm title .help {Help} |
||
| 2185 | wm iconname .help {Help} |
||
| 2186 | button .help.dismiss -text Dismiss -command {catch {destroy .help}} |
||
| 2187 | pack .help.dismiss -side bottom |
||
| 2188 | text .help.t -yscrollcommand ".help.sb set" -wrap word -width 60 |
||
| 2189 | pack .help.t -side left -fill both -expand 1 |
||
| 2190 | scrollbar .help.sb -orient vertical -command ".help.t yview" |
||
| 2191 | pack .help.sb -side right -fill y |
||
| 2192 | .help.t tag config heading -justify center \ |
||
| 2193 | -font -adobe-helvetica-bold-r-normal-*-18-180-75-75-p-103-iso8859-1 |
||
| 2194 | .help.t tag config bold -font \ |
||
| 2195 | -adobe-helvetica-bold-r-normal-*-14-140-75-75-p-82-iso8859-1 |
||
| 2196 | .help.t tag config normal -justify left \ |
||
| 2197 | -font -adobe-helvetica-medium-r-normal-*-14-140-75-75-p-77-iso8859-1 |
||
| 2198 | if {![info exists Help($subject)]} { |
||
| 2199 | set msg $Help(unknown) |
||
| 2200 | } else { |
||
| 2201 | set msg $Help($subject) |
||
| 2202 | } |
||
| 2203 | .help.t delete 1.0 end |
||
| 2204 | set cnt 0 |
||
| 2205 | set linestart 0 |
||
| 2206 | set ll [llength $msg] |
||
| 2207 | for {set i 0} {$i<$ll} {incr i} { |
||
| 2208 | set cmd [lindex $msg $i] |
||
| 2209 | switch $cmd { |
||
| 2210 | heading - |
||
| 2211 | text - |
||
| 2212 | bold { |
||
| 2213 | incr i |
||
| 2214 | set txt [lindex $msg $i] |
||
| 2215 | regsub -all "\n *" $txt { } txt |
||
| 2216 | } |
||
| 2217 | } |
||
| 2218 | switch $cmd { |
||
| 2219 | heading { |
||
| 2220 | if {$cnt>0} {.help.t insert end \n\n heading} |
||
| 2221 | .help.t insert end $txt\n\n heading |
||
| 2222 | set linestart 1 |
||
| 2223 | } |
||
| 2224 | text { |
||
| 2225 | if {!$linestart} {.help.t insert end " " normal} |
||
| 2226 | .help.t insert end $txt normal |
||
| 2227 | set linestart 0 |
||
| 2228 | } |
||
| 2229 | bold { |
||
| 2230 | if {!$linestart} {.help.t insert end " " normal} |
||
| 2231 | .help.t insert end $txt bold |
||
| 2232 | set linestart 0 |
||
| 2233 | } |
||
| 2234 | paragraph { |
||
| 2235 | .help.t insert end "\n\n" normal |
||
| 2236 | set linestart 1 |
||
| 2237 | } |
||
| 2238 | } |
||
| 2239 | incr cnt |
||
| 2240 | } |
||
| 2241 | .help.t config -state disabled |
||
| 2242 | } |
||
| 2243 | |||
| 2244 | # The help screens |
||
| 2245 | # |
||
| 2246 | set Help(About) { |
||
| 2247 | heading {About XMktclapp} |
||
| 2248 | text {This is xmktclapp.tcl version 3.9, released on January 30, 2000. |
||
| 2249 | XMktclapp itself and the associated mktclapp program are both |
||
| 2250 | covered by the GNU Public License. The code that |
||
| 2251 | xmktclapp generates is in the public domain.} |
||
| 2252 | paragraph |
||
| 2253 | text {Report bugs to drh@acm.org.} |
||
| 2254 | paragraph |
||
| 2255 | text {If you find this program useful, a note to the |
||
| 2256 | author would be appreciated. drh@acm.org.} |
||
| 2257 | } |
||
| 2258 | |||
| 2259 | set Help(What) { |
||
| 2260 | heading {Introduction} |
||
| 2261 | text {This program, and a related program "mktclapp", are used to help |
||
| 2262 | convert a collection of Tcl/Tk and C/C++ source files into |
||
| 2263 | a single stand-alone executable that will run on machines that |
||
| 2264 | do not have Tcl/Tk installed.} |
||
| 2265 | paragraph |
||
| 2266 | text {Fill in the information on the various notebook pages, then |
||
| 2267 | choose the File/Build menu option. That will generate a |
||
| 2268 | C source code file and an associated header file |
||
| 2269 | that contain all of your Tcl/Tk code |
||
| 2270 | embedded in static strings. The generated C code will also |
||
| 2271 | contain routines to initialize the Tcl/Tk interpreter.} |
||
| 2272 | paragraph |
||
| 2273 | text {Most entry boxes and menus have a help button nearby. Press |
||
| 2274 | these help buttons for additional information about the particular |
||
| 2275 | entry box or menu.} |
||
| 2276 | } |
||
| 2277 | |||
| 2278 | set Help(unknown) { |
||
| 2279 | heading {Unknown Topic} |
||
| 2280 | text {No help is available at this time for the topic you |
||
| 2281 | have specified. Sorry...} |
||
| 2282 | } |
||
| 2283 | |||
| 2284 | set Help(Mode) { |
||
| 2285 | heading {Application Mode} |
||
| 2286 | text {The "mktclapp" application generator can produce code that uses |
||
| 2287 | only Tcl (no GUI) or that uses both Tcl and Tk (with a GUI). |
||
| 2288 | A third option, called "Extension", will cause mktclapp to |
||
| 2289 | output code for a Tcl extension library or DLL rather than a |
||
| 2290 | a complete application.} |
||
| 2291 | paragraph |
||
| 2292 | text {The "Tcl Only" option is only useful for Unix. |
||
| 2293 | Under Windows, use only "Tcl/Tk" or "Extension".} |
||
| 2294 | paragraph |
||
| 2295 | text {If the "Extension" option is chosen, the name of the extension |
||
| 2296 | will be derived from the name of the Output C File.} |
||
| 2297 | } |
||
| 2298 | |||
| 2299 | set Help(Autofork) { |
||
| 2300 | heading {Fork Into Background?} |
||
| 2301 | text {If you select "Yes" for the "Fork Into Background" option |
||
| 2302 | then the generated application will automatically |
||
| 2303 | run in the background, disconnected from its controlling terminal. |
||
| 2304 | This is often a useful feature for GUIs.} |
||
| 2305 | paragraph |
||
| 2306 | text {Only set the option to "Yes" under Unix. Under MS-Windows always |
||
| 2307 | set this option to "No". The Window C compiler will make the |
||
| 2308 | necessary arrangements to fork Windows GUIs |
||
| 2309 | into the background.} |
||
| 2310 | paragraph |
||
| 2311 | text {It is hard to use a debugger on an application running in the |
||
| 2312 | background, so while debugging it is best to leave this option |
||
| 2313 | turned off. You can always turn it on before a "real" build if |
||
| 2314 | it is the behavior that you want.} |
||
| 2315 | } |
||
| 2316 | |||
| 2317 | set Help(Standalone) { |
||
| 2318 | heading {Standalone} |
||
| 2319 | text {If Standalone is "Yes", |
||
| 2320 | then the generated code will run on binary-compatible |
||
| 2321 | machines that do not have Tcl/Tk installed. If you choose "No", |
||
| 2322 | then Tcl/Tk must be installed on the machine for your application |
||
| 2323 | to work properly.} |
||
| 2324 | paragraph |
||
| 2325 | text {Setting Standalone to "Strict" is like setting it to "Yes" but |
||
| 2326 | with the following addition: When Standalone is "Strict" the |
||
| 2327 | "source" command of Tcl is modified so that it can only see |
||
| 2328 | files that have been compiled into your binary. In other words, |
||
| 2329 | when Standalone is "Strict", only files listed on the "Tcl Scripts" |
||
| 2330 | page and in the Tcl/Tk library directories can be sourced. The |
||
| 2331 | strict standalone mode helps detect the common bug of omitting |
||
| 2332 | one or more Tcl scripts from the "Tcl Scripts" page.} |
||
| 2333 | paragraph |
||
| 2334 | text {In order to be truely standalone, you must also link your application |
||
| 2335 | against the static Tcl/Tk libraries, not the dynamic or shared |
||
| 2336 | libraries. How you do this depends on your compiler. Typically, |
||
| 2337 | you give the compiler an option like "-static" or "-Bstatic". Or |
||
| 2338 | you can specify the static Tcl/Tk library files on the compiler |
||
| 2339 | command line, like this: "/usr/lib/libtcl8.0.a", instead of using |
||
| 2340 | the compiler's -l option like this: "-ltcl8.0".} |
||
| 2341 | } |
||
| 2342 | |||
| 2343 | set Help(ConfigFile) { |
||
| 2344 | heading {Configuration File} |
||
| 2345 | text {This entry contains the name of a file that holds the |
||
| 2346 | configuration information used by both mktclapp and xmktclapp. |
||
| 2347 | By convention, this file has a ".mta" suffix.} |
||
| 2348 | paragraph |
||
| 2349 | text {XMktclapp reads in the first configuration |
||
| 2350 | file it finds in when it is first invoked. You can read a |
||
| 2351 | different configuration file using the "Open" button. |
||
| 2352 | To save the current configuration file to a different filename, |
||
| 2353 | use the "Save As" button.} |
||
| 2354 | } |
||
| 2355 | |||
| 2356 | set Help(OutputFile) { |
||
| 2357 | heading {Output C File} |
||
| 2358 | text {This entry contains the name of the file into which C code |
||
| 2359 | is written when you press the |
||
| 2360 | "Build" button or choose the File/Build menu option. If you |
||
| 2361 | run mktclapp manually, the generated C code appears on |
||
| 2362 | standard output.} |
||
| 2363 | paragraph |
||
| 2364 | text {Pressing the "Build" button also generates a header file. |
||
| 2365 | The name of the header file is the same as the name of the C |
||
| 2366 | file except that the suffix is changed to ".h".} |
||
| 2367 | } |
||
| 2368 | |||
| 2369 | set Help(TclLib) { |
||
| 2370 | heading {Tcl Library} |
||
| 2371 | text {The Tcl Library is a directory on your computer that contains |
||
| 2372 | a bunch of Tcl scripts and an index (named "tclIndex") that are |
||
| 2373 | needed for many applications. In a stand-alone executable, |
||
| 2374 | these scripts must be compiled into the executable because they |
||
| 2375 | might not exist on the target machine.} |
||
| 2376 | paragraph |
||
| 2377 | text {The mktclapp program will automatically add the Tcl Library |
||
| 2378 | scripts to your executable if you select Standalone mode on |
||
| 2379 | the Settings page. But you have to tell mktclapp where to go |
||
| 2380 | to look for the Tcl scripts. Enter the name of the directory |
||
| 2381 | that contains the Tcl scripts you want to use here.} |
||
| 2382 | paragraph |
||
| 2383 | text {If you have more than one version of Tcl/Tk installed on your |
||
| 2384 | machine, there will be more than one Tcl Library directory. |
||
| 2385 | Make sure you chose a Tcl Library that is compatible with the |
||
| 2386 | Tcl C Library.} |
||
| 2387 | } |
||
| 2388 | |||
| 2389 | set Help(TkLib) { |
||
| 2390 | heading {Tk Library} |
||
| 2391 | text {The Tk Library is a directory on your computer that contains |
||
| 2392 | a bunch of Tcl scripts and an index (named "tclIndex") that are |
||
| 2393 | needed for many applications. In a stand-alone executable, |
||
| 2394 | these scripts must be compiled into the executable because they |
||
| 2395 | might not exist on the target machine.} |
||
| 2396 | paragraph |
||
| 2397 | text {The mktclapp program will automatically add the Tk Library |
||
| 2398 | scripts to your executable if you select Standalone mode on |
||
| 2399 | the Settings page. But you have to tell mktclapp where to go |
||
| 2400 | to look for the Tcl scripts by entering a directory name here.} |
||
| 2401 | paragraph |
||
| 2402 | text {If you have more than one version of Tcl/Tk installed on your |
||
| 2403 | machine, there will be more than one Tk Library directory. |
||
| 2404 | Make sure you chose a Tk Library that is compatible with the |
||
| 2405 | Tk C Library that you are linking against.} |
||
| 2406 | } |
||
| 2407 | |||
| 2408 | set Help(OtherLib) { |
||
| 2409 | heading {Other Script Libraries} |
||
| 2410 | text {Put in this listbox the names of directories that contain |
||
| 2411 | script libraries other than the standard Tcl and Tk script |
||
| 2412 | libraries. Every file in the named directories that ends with |
||
| 2413 | ".tcl" or whose name is "tclIndex" will be compiled into your |
||
| 2414 | executable when you build with Standalone set to "Yes" or |
||
| 2415 | "Strict".} |
||
| 2416 | paragraph |
||
| 2417 | text {This listbox is designed to load the script libraries associated |
||
| 2418 | with Tcl extensions, like Tix, [incr tcl], or TclX.} |
||
| 2419 | } |
||
| 2420 | |||
| 2421 | set Help(C/C++) { |
||
| 2422 | heading {C and C++ Source Files} |
||
| 2423 | text {This page lists all the C and C++ source files that will be |
||
| 2424 | used by your application. (Except, the C source file generated |
||
| 2425 | by this program should not be listed!)} |
||
| 2426 | paragraph |
||
| 2427 | text {The mktclapp application generator scans all of the C source files |
||
| 2428 | you list looking for function definitions with a name of the form |
||
| 2429 | "ET_COMMAND_aaaaa(ET_TCLARGS)". For each such function definition |
||
| 2430 | found, mktclapp will create a new Tcl command named "aaaaa" that |
||
| 2431 | is implemented by the C function.} |
||
| 2432 | paragraph |
||
| 2433 | text {Mktclapp also extracts some other information it needs by scanning |
||
| 2434 | source files, so it is important to list all the source files for |
||
| 2435 | your application here, even if they contain no new Tcl command |
||
| 2436 | implementations.} |
||
| 2437 | } |
||
| 2438 | |||
| 2439 | set Help(DataFiles) { |
||
| 2440 | heading {Data Files} |
||
| 2441 | text {This page is intended as a place to put the names of image |
||
| 2442 | files, GIFs, and bitmaps. But any kind of binary data file |
||
| 2443 | can be named here. Each file named on this page will be |
||
| 2444 | compiled into the application as a static array of bytes.} |
||
| 2445 | paragraph |
||
| 2446 | text {Tcl/Tk scripts can be named on this page and then run from the |
||
| 2447 | main script using the "source" command. But scripts entered |
||
| 2448 | on this page are neither shrouded nor compressed.} |
||
| 2449 | paragraph |
||
| 2450 | text {Data files named on this page will not be accessible if you |
||
| 2451 | compile with a version of Tcl before 8.0.3} |
||
| 2452 | } |
||
| 2453 | |||
| 2454 | set Help(Tcl) { |
||
| 2455 | heading {Tcl Scripts} |
||
| 2456 | text {This page lists Tcl Scripts that will be converted into C strings |
||
| 2457 | and compiled into your application. You can invoke any of these |
||
| 2458 | scripts by executing the Tcl command} |
||
| 2459 | bold {source FILENAME} |
||
| 2460 | text {where "FILENAME" is replaced by the exact same text that appears |
||
| 2461 | in the window. Note that the FILENAME on the source command must |
||
| 2462 | be character-by-character identical to the name that appears on |
||
| 2463 | this page, or the source command will not work} |
||
| 2464 | paragraph |
||
| 2465 | text {Only your own Tcl Scripts should be listed here. The Tcl/Tk Library |
||
| 2466 | Tcl Scripts are loaded automatically when you select the Standalone |
||
| 2467 | option on the Settings page. See the help on the Standalone option, |
||
| 2468 | and the help on the Libraries page for more information.} |
||
| 2469 | paragraph |
||
| 2470 | text {To save space, mktclapp can attempt to strip comments and |
||
| 2471 | excess whitespace from your Tcl |
||
| 2472 | scripts before compiling them into your application. But on some |
||
| 2473 | rare occasions, a Tcl script will not work correctly if its comments |
||
| 2474 | are removed. On this page, an asterisk appears to the left of |
||
| 2475 | every Tcl Script which will have its comments removed. Use the |
||
| 2476 | "Don't Strip Comments" |
||
| 2477 | button to turn this feature off if you need to.} |
||
| 2478 | } |
||
| 2479 | |||
| 2480 | set Help(Shroud) { |
||
| 2481 | heading {Shroud Tcl Scripts} |
||
| 2482 | text {Normally, the Tcl Scripts that are compiled into your executable |
||
| 2483 | can be easily extracted and read using the "strings" command of |
||
| 2484 | Unix. But if you select the Shroud options, the compiled-in Tcl |
||
| 2485 | Scripts are encoded in a way that makes them much more difficult |
||
| 2486 | to read. Some users may wish to invoke this option in order to |
||
| 2487 | "protect" their proprietary code from prying eyes.} |
||
| 2488 | paragraph |
||
| 2489 | text {Note that shrouding only makes the code more difficult to read. |
||
| 2490 | It is not impossible. A clever hacker can |
||
| 2491 | still access your code. But the same is true of C code, which |
||
| 2492 | can be de-compiled using commercially available tools. No |
||
| 2493 | method of code concealment is perfect.} |
||
| 2494 | paragraph |
||
| 2495 | text {Recent trends are for source code to be accessible and readable |
||
| 2496 | by the end user. We encouraged you to continue this trend by |
||
| 2497 | leaving the Shroud option turned off.} |
||
| 2498 | } |
||
| 2499 | |||
| 2500 | set Help(CmdLine) { |
||
| 2501 | heading {Interactively Reading Tcl Commands} |
||
| 2502 | text {If you want to be able to type commands to Tcl interactively, |
||
| 2503 | set this option to either Stdin or Console. In Stdin mode, |
||
| 2504 | Tcl commands are read from the command-line. In Console mode, |
||
| 2505 | a separate console window is started.} |
||
| 2506 | paragraph |
||
| 2507 | text {This option is useful for testing and debugging during |
||
| 2508 | program development.} |
||
| 2509 | paragraph |
||
| 2510 | text {Console mode only works if you run Tk. It automatically reverts |
||
| 2511 | to Stdin mode if you build a Tcl-only application. Stdin mode |
||
| 2512 | does not work with Tk under Windows. If you select Stdin with |
||
| 2513 | Tk on Windows, it automatically changes to Console mode.} |
||
| 2514 | } |
||
| 2515 | |||
| 2516 | set Help(MainScript) { |
||
| 2517 | heading {Startup Script} |
||
| 2518 | text {A Startup Script is a single Tcl script that is run as soon |
||
| 2519 | as the interpreter has been initialized. This is the script |
||
| 2520 | the draws the main screen of an application, or does other |
||
| 2521 | one-time setup to get the program going.} |
||
| 2522 | paragraph |
||
| 2523 | text {If the Startup entry box is blank, no startup script will be run. |
||
| 2524 | If a Startup script is specified, but cannot be located, or if |
||
| 2525 | the Startup script contains an error, no error message is reported |
||
| 2526 | back to the user.} |
||
| 2527 | paragraph |
||
| 2528 | text {The Startup script is not automatically compiled into the |
||
| 2529 | executable. If you need the Startup script to be compiled into |
||
| 2530 | the executable (as most applications do) then you must include |
||
| 2531 | the script in the list of Tcl Scripts to be compiled in, in addition |
||
| 2532 | to putting it in the Startup entry box.} |
||
| 2533 | } |
||
| 2534 | |||
| 2535 | SetDefaults |
||
| 2536 | frame .mb -bd 2 -relief raised |
||
| 2537 | pack .mb -side top -fill x |
||
| 2538 | menubutton .mb.file -text File -menu .mb.file.m |
||
| 2539 | pack .mb.file -side left -padx 5 |
||
| 2540 | set m [menu .mb.file.m] |
||
| 2541 | $m add command -label "Open..." -underline 0 -command DoOpen |
||
| 2542 | $m add command -label "Save" -underline 0 -command DoSave |
||
| 2543 | $m add command -label "Save As..." -underline 5 -command DoSaveAs |
||
| 2544 | $m add command -label "Build" -underline 0 -command DoBuild |
||
| 2545 | $m add separator |
||
| 2546 | $m add command -label Exit -underline 1 -command DoExit |
||
| 2547 | |||
| 2548 | menubutton .mb.help -text Help -menu .mb.help.m |
||
| 2549 | pack .mb.help -side left -padx 5 |
||
| 2550 | set m [menu .mb.help.m] |
||
| 2551 | $m add command -label "About This Program..." -underline 0 \ |
||
| 2552 | -command "DoHelp About" |
||
| 2553 | $m add command -label "Introduction..." -underline 0 -command "DoHelp What" |
||
| 2554 | |||
| 2555 | set NotebookPages {Settings Libraries {C/C++ Modules} {Tcl Scripts} \ |
||
| 2556 | {Data Files}} |
||
| 2557 | Notebook:create .n -pad 10 -pages $NotebookPages |
||
| 2558 | pack .n -fill both -expand 1 |
||
| 2559 | set w [Notebook:frame .n Settings] |
||
| 2560 | |||
| 2561 | proc Page1Option {w text var choices help} { |
||
| 2562 | frame $w |
||
| 2563 | pack $w -side top -fill x -pady 3 |
||
| 2564 | label $w.l -text $text -anchor e -width 28 |
||
| 2565 | eval tk_optionMenu $w.e conf($var) $choices |
||
| 2566 | $w.e config -width 8 |
||
| 2567 | button $w.h -text Help -command "DoHelp $help" |
||
| 2568 | pack $w.l $w.e -side left |
||
| 2569 | pack $w.h -side left -fill y |
||
| 2570 | } |
||
| 2571 | |||
| 2572 | frame $w.spacer -height 5 |
||
| 2573 | pack $w.spacer -side top |
||
| 2574 | Page1Option $w.f1 {Application Mode} Mode {{Extension} {Tcl Only} {Tcl/Tk}} Mode |
||
| 2575 | Page1Option $w.f2 {Fork Into Background?} Autofork {Yes No} Autofork |
||
| 2576 | Page1Option $w.f3 {Command Line Input?} CmdLine {Console Stdin None} CmdLine |
||
| 2577 | Page1Option $w.f4 {Standalone?} Standalone {Strict Yes No} Standalone |
||
| 2578 | Page1Option $w.f5 {Shroud Tcl Scripts?} Shroud {Yes No} Shroud |
||
| 2579 | set f [LabelFrame:create $w.f7 -text "Configuration File" -ipadx 10 -ipady 7 -bd 4] |
||
| 2580 | pack $w.f7 -side top -fill x |
||
| 2581 | entry $f.e -bd 2 -relief sunken -bg white -fg black \ |
||
| 2582 | -textvariable conf(ConfigFile) -width 30 -font fixed |
||
| 2583 | pack $f.e -side top -fill x |
||
| 2584 | button $f.open -text Open -command DoOpen |
||
| 2585 | button $f.save -text Save -command DoSave |
||
| 2586 | button $f.saveas -text {Save As} -command DoSaveAs |
||
| 2587 | button $f.help -text Help -command "DoHelp ConfigFile" |
||
| 2588 | pack $f.help $f.saveas $f.save $f.open -side right -pady 5 |
||
| 2589 | set f [LabelFrame:create $w.f8 -text "Output C File" -ipadx 10 -ipady 7 -bd 4] |
||
| 2590 | pack $w.f8 -side top -fill x |
||
| 2591 | entry $f.e -bd 2 -relief sunken -bg white -fg black \ |
||
| 2592 | -textvariable conf(OutputFile) -width 30 -font fixed |
||
| 2593 | pack $f.e -side top -fill x |
||
| 2594 | button $f.br -text Browse -command BrowseForOutputFile |
||
| 2595 | button $f.rp -text {Relative Path} -command "RelAbsPath $f.rp conf(OutputFile)" |
||
| 2596 | trace variable conf(OutputFile) w "TracePath $f.rp conf(OutputFile)" |
||
| 2597 | button $f.bld -text {Build} -command DoBuild |
||
| 2598 | button $f.help -text Help -command "DoHelp OutputFile" |
||
| 2599 | pack $f.help $f.bld $f.rp $f.br -side right -pady 5 |
||
| 2600 | |||
| 2601 | # An Easter Egg: Clicking on the Help button within the Output C File |
||
| 2602 | # box while holding down both Control and Shift causes a debugging console |
||
| 2603 | # to come up. The debugging console can be used to type Tcl commands |
||
| 2604 | # directly into a running instance of this program. Very useful on |
||
| 2605 | # Windows, since TkCon doesn't work there. |
||
| 2606 | # |
||
| 2607 | bind $f.help <Control-Shift-1> { |
||
| 2608 | OpenConsole .con {Debug> } |
||
| 2609 | break |
||
| 2610 | } |
||
| 2611 | |||
| 2612 | # This routine runs whenever the value of conf(Mode) changes. |
||
| 2613 | # |
||
| 2614 | proc ModeChanged {args} { |
||
| 2615 | global conf |
||
| 2616 | set w [Notebook:frame .n Settings] |
||
| 2617 | switch $conf(Mode) { |
||
| 2618 | {Tcl Only} - |
||
| 2619 | {Tcl/Tk} { |
||
| 2620 | foreach v {Autofork CmdLine Standalone} { |
||
| 2621 | if {[info exists conf(saved-$v)]} { |
||
| 2622 | set conf($v) $conf(saved-$v) |
||
| 2623 | } |
||
| 2624 | } |
||
| 2625 | foreach f {f2 f3 f4} { |
||
| 2626 | $w.$f.e config -state normal |
||
| 2627 | $w.$f.l config -fg [$w.$f.e cget -foreground] |
||
| 2628 | } |
||
| 2629 | } |
||
| 2630 | {Extension} { |
||
| 2631 | foreach v {Autofork CmdLine Standalone} { |
||
| 2632 | set conf(saved-$v) $conf($v) |
||
| 2633 | } |
||
| 2634 | set conf(saved-Autofork) $conf(Autofork) |
||
| 2635 | set conf(saved-CmdLine) $conf(CmdLine) |
||
| 2636 | set conf(saved-Standalone) $conf(Standalone) |
||
| 2637 | set conf(Autofork) No |
||
| 2638 | set conf(CmdLine) None |
||
| 2639 | set conf(Standalone) Yes |
||
| 2640 | foreach f {f2 f3 f4} { |
||
| 2641 | $w.$f.e config -state disabled |
||
| 2642 | $w.$f.l config -fg [$w.$f.e cget -disabledforeground] |
||
| 2643 | } |
||
| 2644 | } |
||
| 2645 | } |
||
| 2646 | } |
||
| 2647 | trace variable conf(Mode) w ModeChanged |
||
| 2648 | |||
| 2649 | set w [Notebook:frame .n {C/C++ Modules}] |
||
| 2650 | frame $w.c |
||
| 2651 | frame $w.b |
||
| 2652 | pack $w.c -side top -fill both -expand 1 -pady 10 -padx 10 |
||
| 2653 | pack $w.b -side top -pady 10 |
||
| 2654 | button $w.b.ins -text Insert -command DoInsertC |
||
| 2655 | button $w.b.del -text Delete -command DoDeleteC -state disabled |
||
| 2656 | button $w.b.rp -text {Relative Path} -width 12 -command CChngPath |
||
| 2657 | button $w.b.help -text Help -command "DoHelp C/C++" |
||
| 2658 | pack $w.b.ins $w.b.del $w.b.rp $w.b.help -expand 1 -side left |
||
| 2659 | listbox $w.c.lb -yscrollcommand "$w.c.sb set" -bg white -exportselection 0 \ |
||
| 2660 | -width 50 -font fixed -fg black |
||
| 2661 | bind $w.c.lb <1> {after idle SetCSelect} |
||
| 2662 | pack $w.c.lb -side left -fill both -expand 1 |
||
| 2663 | scrollbar $w.c.sb -orient vertical -command "$w.c.lb yview" |
||
| 2664 | pack $w.c.sb -side right -fill y |
||
| 2665 | InsertC |
||
| 2666 | |||
| 2667 | set w [Notebook:frame .n {Tcl Scripts}] |
||
| 2668 | frame $w.c |
||
| 2669 | set f1 [LabelFrame:create $w.m -text "Startup Script" -ipadx 10 -ipady 10 -bd 4] |
||
| 2670 | frame $w.b |
||
| 2671 | frame $w.b2 |
||
| 2672 | frame $w.sp -height 8 |
||
| 2673 | frame $w.bar -height 4 -relief sunken -bd 2 |
||
| 2674 | pack $w.sp -side top -pady 1 |
||
| 2675 | pack $w.c -side top -pady 1 -fill both -expand 1 -padx 10 |
||
| 2676 | pack $w.b $w.b2 -side top -pady 1 |
||
| 2677 | pack $w.bar -side top -fill x -pady 5 |
||
| 2678 | pack $w.m -side top -pady 15 -fill x -padx 10 |
||
| 2679 | button $w.b.ins -text Insert -command DoInsertTcl |
||
| 2680 | button $w.b.del -text Delete -command DoDeleteTcl -state disabled |
||
| 2681 | button $w.b.stc -text {Do Strip Comments} -width 20 -state disabled |
||
| 2682 | button $w.b2.rp -text {Relative Path} -width 12 -state disabled \ |
||
| 2683 | -command TclChngPath |
||
| 2684 | button $w.b2.help -text Help -command "DoHelp Tcl" |
||
| 2685 | pack $w.b.ins $w.b.del $w.b.stc -side left -expand 1 |
||
| 2686 | pack $w.b2.rp $w.b2.help -side left |
||
| 2687 | entry $f1.e -bd 2 -bg white -relief sunken -textvariable conf(MainScript) \ |
||
| 2688 | -width 50 -font fixed -fg black |
||
| 2689 | pack $f1.e -side top -fill x |
||
| 2690 | button $f1.s -text {Browse} -command BrowseForMainScript |
||
| 2691 | button $f1.rp -text {Relative Path} -width 12 \ |
||
| 2692 | -command "MainScriptChngPath $f1.rp" |
||
| 2693 | trace variable conf(MainScript) w "TracePath $f1.rp conf(MainScript)" |
||
| 2694 | button $f1.h -text {Help} -command "DoHelp MainScript" |
||
| 2695 | pack $f1.h $f1.rp $f1.s -side right |
||
| 2696 | listbox $w.c.lb -yscrollcommand "$w.c.sb set" -bg white -exportselection 0 \ |
||
| 2697 | -width 30 -font [$f1.e cget -font] -fg black -height 3 |
||
| 2698 | bind $w.c.lb <1> {after idle SetTclSelect} |
||
| 2699 | pack $w.c.lb -side left -fill both -expand 1 |
||
| 2700 | scrollbar $w.c.sb -orient vertical -command "$w.c.lb yview" |
||
| 2701 | pack $w.c.sb -side right -fill y |
||
| 2702 | InsertTcl |
||
| 2703 | |||
| 2704 | set w [Notebook:frame .n Libraries] |
||
| 2705 | set f1 [LabelFrame:create $w.f1 -text "Tcl Script Library" \ |
||
| 2706 | -ipadx 10 -ipady 2 -bd 4] |
||
| 2707 | entry $f1.e -bd 2 -relief sunken -bg white -textvariable conf(TclLib) \ |
||
| 2708 | -width 40 -font fixed -fg black |
||
| 2709 | pack $f1.e -side top -pady 5 -fill x |
||
| 2710 | button $f1.b -text Browse -command BrowseForTclLib |
||
| 2711 | button $f1.rp -text {Relative Path} -width 12 \ |
||
| 2712 | -command "RelAbsPath $f1.rp conf(TclLib)" |
||
| 2713 | trace variable conf(TclLib) w "TracePath $f1.rp conf(TclLib)" |
||
| 2714 | button $f1.g -text Guess -command { |
||
| 2715 | catch {set conf(TclLib) $tcl_library} |
||
| 2716 | } |
||
| 2717 | button $f1.h -text Help -command "DoHelp TclLib" |
||
| 2718 | pack $f1.h $f1.g $f1.rp $f1.b -side right |
||
| 2719 | pack $w.f1 -side top -padx 10 -pady 5 -fill x |
||
| 2720 | set f2 [LabelFrame:create $w.f2 -text "Tk Script Library" \ |
||
| 2721 | -ipadx 10 -ipady 2 -bd 4] |
||
| 2722 | entry $f2.e -bd 2 -relief sunken -bg white -textvariable conf(TkLib) \ |
||
| 2723 | -width 40 -font fixed -fg black |
||
| 2724 | pack $f2.e -side top -pady 5 -fill x |
||
| 2725 | button $f2.b -text Browse -command BrowseForTkLib |
||
| 2726 | button $f2.rp -text {Relative Path} -width 12 \ |
||
| 2727 | -command "RelAbsPath $f2.rp conf(TkLib)" |
||
| 2728 | trace variable conf(TkLib) w "TracePath $f2.rp conf(TkLib)" |
||
| 2729 | button $f2.g -text Guess -command { |
||
| 2730 | catch {set conf(TkLib) $tk_library} |
||
| 2731 | } |
||
| 2732 | button $f2.h -text Help -command "DoHelp TkLib" |
||
| 2733 | pack $f2.h $f2.g $f2.rp $f2.b -side right |
||
| 2734 | pack $w.f2 -side top -padx 10 -pady 5 -fill x |
||
| 2735 | set f3 [LabelFrame:create $w.f3 -text "Other Script Libraries" \ |
||
| 2736 | -ipadx 10 -ipady 2 -bd 4] |
||
| 2737 | set widget(OtherLib) $f3 |
||
| 2738 | frame $f3.b |
||
| 2739 | listbox $f3.lb -font [$f2.e cget -font] -yscrollcommand "$f3.sb set" \ |
||
| 2740 | -height 3 -bg white -fg black -exportselection 0 |
||
| 2741 | bind $f3.lb <1> {after idle SetOtherLibSelect} |
||
| 2742 | scrollbar $f3.sb -orient vertical -command "$f3.lb yview" |
||
| 2743 | pack $f3.b -side bottom -fill x |
||
| 2744 | pack $f3.lb -side left -fill both -expand 1 -pady 5 |
||
| 2745 | pack $f3.sb -side left -fill y -pady 5 |
||
| 2746 | button $f3.b.help -text Help -command "DoHelp OtherLib" |
||
| 2747 | button $f3.b.rp -text {Relative Path} -width 12 -command OtherLibChngPath |
||
| 2748 | button $f3.b.ins -text {Insert} -command DoInsertOtherLib |
||
| 2749 | button $f3.b.del -text {Delete} -command DoDeleteOtherLib |
||
| 2750 | pack $f3.b.help $f3.b.rp $f3.b.del $f3.b.ins -side right |
||
| 2751 | pack $w.f3 -side top -padx 10 -pady 5 -fill both -expand 1 |
||
| 2752 | SetOtherLibSelect |
||
| 2753 | |||
| 2754 | set w [Notebook:frame .n Makefile] |
||
| 2755 | if {$w!=""} { |
||
| 2756 | set f [LabelFrame:create $w.f1 -text "C Compiler and Options" \ |
||
| 2757 | -ipadx 10 -ipady 2 -bd 4] |
||
| 2758 | entry $f.e -bd 2 -relief sunken -bg white -textvariable conf(CC) \ |
||
| 2759 | -width 60 -font fixed -fg black |
||
| 2760 | button $f.h -text Help -command "DoHelp CC" |
||
| 2761 | pack $f.h -side right |
||
| 2762 | pack $f.e -side top -pady 5 -fill x |
||
| 2763 | pack $w.f1 -side top -padx 10 -pady 5 -fill x |
||
| 2764 | set f [LabelFrame:create $w.f2 -text "Linker and Options" \ |
||
| 2765 | -ipadx 10 -ipady 2 -bd 4] |
||
| 2766 | entry $f.e -bd 2 -relief sunken -bg white -textvariable conf(Linker) \ |
||
| 2767 | -width 60 -font fixed -fg black |
||
| 2768 | button $f.h -text Help -command "DoHelp Linker" |
||
| 2769 | pack $f.h -side right |
||
| 2770 | pack $f.e -side top -pady 5 -fill x |
||
| 2771 | pack $w.f2 -side top -padx 10 -pady 5 -fill x |
||
| 2772 | set f [LabelFrame:create $w.f3 -text "Linker Arguments" \ |
||
| 2773 | -ipadx 10 -ipady 2 -bd 4] |
||
| 2774 | entry $f.e -bd 2 -relief sunken -bg white -textvariable conf(LinkArg) \ |
||
| 2775 | -width 60 -font fixed -fg black |
||
| 2776 | button $f.h -text Help -command "DoHelp LinkArg" |
||
| 2777 | pack $f.h -side right |
||
| 2778 | pack $f.e -side top -pady 5 -fill x |
||
| 2779 | pack $w.f3 -side top -padx 10 -pady 5 -fill x |
||
| 2780 | } |
||
| 2781 | |||
| 2782 | set w [Notebook:frame .n {Data Files}] |
||
| 2783 | if {$w!=""} { |
||
| 2784 | frame $w.c |
||
| 2785 | frame $w.b |
||
| 2786 | pack $w.c -side top -fill both -expand 1 -pady 10 -padx 10 |
||
| 2787 | pack $w.b -side top -pady 10 |
||
| 2788 | button $w.b.ins -text Insert -command DoInsertData |
||
| 2789 | button $w.b.del -text Delete -command DoDeleteData -state disabled |
||
| 2790 | button $w.b.rp -text {Relative Path} -width 12 -command DataChngPath |
||
| 2791 | button $w.b.help -text Help -command "DoHelp DataFiles" |
||
| 2792 | pack $w.b.ins $w.b.del $w.b.rp $w.b.help -expand 1 -side left |
||
| 2793 | listbox $w.c.lb -yscrollcommand "$w.c.sb set" -bg white -exportselection 0 \ |
||
| 2794 | -width 50 -font fixed -fg black |
||
| 2795 | bind $w.c.lb <1> {after idle SetDataSelect} |
||
| 2796 | pack $w.c.lb -side left -fill both -expand 1 |
||
| 2797 | scrollbar $w.c.sb -orient vertical -command "$w.c.lb yview" |
||
| 2798 | pack $w.c.sb -side right -fill y |
||
| 2799 | InsertData |
||
| 2800 | } |
||
| 2801 | |||
| 2802 | wm withdraw . |
||
| 2803 | update idletasks |
||
| 2804 | set W 420 |
||
| 2805 | set H 200 |
||
| 2806 | foreach f $NotebookPages { |
||
| 2807 | set w [Notebook:frame .n $f] |
||
| 2808 | if {[winfo reqwidth $w]>$W} { |
||
| 2809 | set W [winfo reqwidth $w] |
||
| 2810 | } |
||
| 2811 | if {[winfo reqheight $w]>$H} { |
||
| 2812 | set H [winfo reqheight $w] |
||
| 2813 | } |
||
| 2814 | } |
||
| 2815 | Notebook:config .n -width $W -height $H |
||
| 2816 | wm deiconify . |
||
| 2817 | wm protocol . WM_DELETE_WINDOW DoExit |
||
| 2818 | wm protocol . WM_SAVE_YOURSELF DoSave |
||
| 2819 | set filelist [glob -nocomplain *.mta] |
||
| 2820 | if {[llength $filelist]==0} { |
||
| 2821 | InsertC |
||
| 2822 | InsertTcl |
||
| 2823 | } else { |
||
| 2824 | set conf(ConfigFile) [lindex $argv 0] |
||
| 2825 | if {[string length $conf(ConfigFile)]==0 || [ReadState $conf(ConfigFile) 1]} { |
||
| 2826 | set conf(ConfigFile) [lindex [lsort $filelist] 0] |
||
| 2827 | ReadState $conf(ConfigFile) 1 |
||
| 2828 | } |
||
| 2829 | Baseline |
||
| 2830 | } |