1#!/bin/sh 2# the next line restarts using wish \ 3exec wish "$0" "$@" 4 5# widget -- 6# This script demonstrates the various widgets provided by Tk, along with many 7# of the features of the Tk toolkit. This file only contains code to generate 8# the main window for the application, which invokes individual 9# demonstrations. The code for the actual demonstrations is contained in 10# separate ".tcl" files is this directory, which are sourced by this script as 11# needed. 12# 13# RCS: @(#) $Id$ 14 15package require Tcl 8.5 16package require Tk 8.5 17package require msgcat 18package require Ttk 19 20eval destroy [winfo child .] 21set tk_demoDirectory [file join [pwd] [file dirname [info script]]] 22::msgcat::mcload $tk_demoDirectory 23namespace import ::msgcat::mc 24wm title . [mc "Widget Demonstration"] 25if {[tk windowingsystem] eq "x11"} { 26 # This won't work everywhere, but there's no other way in core Tk at the 27 # moment to display a coloured icon. 28 image create photo TclPowered \ 29 -file [file join $tk_library images logo64.gif] 30 wm iconwindow . [toplevel ._iconWindow] 31 pack [label ._iconWindow.i -image TclPowered] 32 wm iconname . [mc "tkWidgetDemo"] 33} 34 35if {"defaultFont" ni [font names]} { 36 # TIP #145 defines some standard named fonts 37 if {"TkDefaultFont" in [font names] && "TkFixedFont" in [font names]} { 38 # FIX ME: the following technique of cloning the font to copy it works 39 # fine but means that if the system font is changed by Tk 40 # cannot update the copied font. font alias might be useful 41 # here -- or fix the app to use TkDefaultFont etc. 42 font create mainFont {*}[font configure TkDefaultFont] 43 font create fixedFont {*}[font configure TkFixedFont] 44 font create boldFont {*}[font configure TkDefaultFont] -weight bold 45 font create titleFont {*}[font configure TkDefaultFont] -weight bold 46 font create statusFont {*}[font configure TkDefaultFont] 47 font create varsFont {*}[font configure TkDefaultFont] 48 if {[tk windowingsystem] eq "aqua"} { 49 font configure titleFont -size 17 50 } 51 } else { 52 font create mainFont -family Helvetica -size 12 53 font create fixedFont -family Courier -size 10 54 font create boldFont -family Helvetica -size 12 -weight bold 55 font create titleFont -family Helvetica -size 18 -weight bold 56 font create statusFont -family Helvetica -size 10 57 font create varsFont -family Helvetica -size 14 58 } 59} 60 61set widgetDemo 1 62set font mainFont 63 64image create photo ::img::refresh -format GIF -data { 65 R0lGODlhEAAQAJEDAP///wAAACpnKv///yH5BAEAAAMALAAAAAAQABAAAAI63IKp 66 xgcPH2ouwgBCw1HIxHCQ4F3hSJKmwZXqWrmWxj7lKJ2dndcon9EBUq+gz3brVXAR 67 2tICU0gXBQA7 68} 69 70image create photo ::img::view -format GIF -data { 71 R0lGODlhEAAQAKIHAP///wwMDAAAAMDAwNnZ2SYmJmZmZv///yH5BAEAAAcALAAA 72 AAAQABAAAANMKLos90+ASamDRxJCgw9YVnlDOXiQBgRDBRgHKE6sW8QR3doPKK27 73 yg33q/GIOhdg6OsEJzeZykiBSUcs06e56Xx6np8ScIkFGuhQAgA7 74} 75 76image create photo ::img::delete -format GIF -data { 77 R0lGODlhEAAQAIABAIQAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjI+pmwAc3HGy 78 PUSvqYpuvWQg40FfSVacBa5nN6JYDI3mzRQAOw== 79} 80 81image create photo ::img::print -format GIF -data { 82 R0lGODlhEAAQALMKAAAAAP///52VunNkl8C82Yl+qldBgq+pyrOzs1fYAP///wAA 83 AAAAAAAAAAAAAAAAACH5BAEAAAoALAAAAAAQABAAAARGUMlJKwU4AztB+ODGeUiJ 84 fGLlgeEYmGWQXmx7aXgmAUTv/74N4EAsGhOJg1DAbDqbwoJ0Sp0KB9isNis0eL/g 85 ryhH5pgnEQA7 86} 87 88# Note that this is run through the message catalog! This is because this is 89# actually an image of a word. 90image create photo ::img::new -format GIF -data [mc { 91 R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3 92 d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw 93 nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM 94 wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1 95 MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7 96}] 97 98#---------------------------------------------------------------- 99# The code below create the main window, consisting of a menu bar and a text 100# widget that explains how to use the program, plus lists all of the demos as 101# hypertext items. 102#---------------------------------------------------------------- 103 104menu .menuBar -tearoff 0 105 106if {[tk windowingsystem] ne "aqua"} { 107 # This is a tk-internal procedure to make i18n easier 108 ::tk::AmpMenuArgs .menuBar add cascade -label [mc "&File"] \ 109 -menu .menuBar.file 110 menu .menuBar.file -tearoff 0 111 ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&About..."] \ 112 -command {tkAboutDialog} -accelerator [mc "<F1>"] 113 bind . <F1> {tkAboutDialog} 114 .menuBar.file add sep 115 if {[string match win* [tk windowingsystem]]} { 116 # Windows doesn't usually have a Meta key 117 ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \ 118 -command {exit} -accelerator [mc "Ctrl+Q"] 119 bind . <[mc "Control-q"]> {exit} 120 } else { 121 ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \ 122 -command {exit} -accelerator [mc "Meta-Q"] 123 bind . <[mc "Meta-q"]> {exit} 124 } 125} 126 127. configure -menu .menuBar 128 129ttk::frame .statusBar 130ttk::label .statusBar.lab -text " " -anchor w 131if {[tk windowingsystem] eq "aqua"} { 132 ttk::separator .statusBar.sep 133 pack .statusBar.sep -side top -expand yes -fill x -pady 0 134} 135pack .statusBar.lab -side left -padx 2 -expand yes -fill both 136if {[tk windowingsystem] ne "aqua"} { 137 ttk::sizegrip .statusBar.foo 138 pack .statusBar.foo -side left -padx 2 139} 140pack .statusBar -side bottom -fill x -pady 2 141 142set textheight 30 143catch { 144 set textheight [expr { 145 ([winfo screenheight .] * 0.7) / 146 [font metrics mainFont -displayof . -linespace] 147 }] 148} 149 150ttk::frame .textFrame 151scrollbar .s -orient vertical -command {.t yview} -takefocus 1 152pack .s -in .textFrame -side right -fill y 153text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \ 154 -font mainFont -setgrid 1 -highlightthickness 0 \ 155 -padx 4 -pady 2 -takefocus 0 156pack .t -in .textFrame -expand y -fill both -padx 1 157pack .textFrame -expand yes -fill both 158if {[tk windowingsystem] eq "aqua"} { 159 pack configure .statusBar.lab -padx {10 18} -pady {4 6} 160 pack configure .statusBar -pady 0 161 .t configure -padx 10 -pady 0 162} 163 164# Create a bunch of tags to use in the text widget, such as those for section 165# titles and demo descriptions. Also define the bindings for tags. 166 167.t tag configure title -font titleFont 168.t tag configure subtitle -font titleFont 169.t tag configure bold -font boldFont 170if {[tk windowingsystem] eq "aqua"} { 171 .t tag configure title -spacing1 8 172 .t tag configure subtitle -spacing3 3 173} 174 175# We put some "space" characters to the left and right of each demo 176# description so that the descriptions are highlighted only when the mouse 177# cursor is right over them (but not when the cursor is to their left or 178# right). 179# 180.t tag configure demospace -lmargin1 1c -lmargin2 1c 181 182if {[winfo depth .] == 1} { 183 .t tag configure demo -lmargin1 1c -lmargin2 1c \ 184 -underline 1 185 .t tag configure visited -lmargin1 1c -lmargin2 1c \ 186 -underline 1 187 .t tag configure hot -background black -foreground white 188} else { 189 .t tag configure demo -lmargin1 1c -lmargin2 1c \ 190 -foreground blue -underline 1 191 .t tag configure visited -lmargin1 1c -lmargin2 1c \ 192 -foreground #303080 -underline 1 193 .t tag configure hot -foreground red -underline 1 194} 195.t tag bind demo <ButtonRelease-1> { 196 invoke [.t index {@%x,%y}] 197} 198set lastLine "" 199.t tag bind demo <Enter> { 200 set lastLine [.t index {@%x,%y linestart}] 201 .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" 202 .t config -cursor [::ttk::cursor link] 203 showStatus [.t index {@%x,%y}] 204} 205.t tag bind demo <Leave> { 206 .t tag remove hot 1.0 end 207 .t config -cursor [::ttk::cursor text] 208 .statusBar.lab config -text "" 209} 210.t tag bind demo <Motion> { 211 set newLine [.t index {@%x,%y linestart}] 212 if {$newLine ne $lastLine} { 213 .t tag remove hot 1.0 end 214 set lastLine $newLine 215 216 set tags [.t tag names {@%x,%y}] 217 set i [lsearch -glob $tags demo-*] 218 if {$i >= 0} { 219 .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" 220 } 221 } 222 showStatus [.t index {@%x,%y}] 223} 224 225############################################################################## 226# Create the text for the text widget. 227 228# addFormattedText -- 229# 230# Add formatted text (but not hypertext) to the text widget after first 231# passing it through the message catalog to allow for localization. 232# Lines starting with @@ are formatting directives (insert title, insert 233# demo hyperlink, begin newline, or change style) and all other lines 234# are literal strings to be inserted. Substitutions are performed, 235# allowing processing pieces through the message catalog. Blank lines 236# are ignored. 237# 238proc addFormattedText {formattedText} { 239 set style normal 240 set isNL 1 241 set demoCount 0 242 set new 0 243 foreach line [split $formattedText \n] { 244 set line [string trim $line] 245 if {$line eq ""} { 246 continue 247 } 248 if {[string match @@* $line]} { 249 set data [string range $line 2 end] 250 set key [lindex $data 0] 251 set values [lrange $data 1 end] 252 switch -exact -- $key { 253 title { 254 .t insert end [mc $values]\n title \n normal 255 } 256 newline { 257 .t insert end \n $style 258 set isNL 1 259 } 260 subtitle { 261 .t insert end "\n" {} [mc $values] subtitle \ 262 " \n " demospace 263 set demoCount 0 264 } 265 demo { 266 set description [lassign $values name] 267 .t insert end "[incr demoCount]. [mc $description]" \ 268 [list demo demo-$name] 269 if {$new} { 270 .t image create end -image ::img::new -padx 5 271 set new 0 272 } 273 .t insert end " \n " demospace 274 } 275 new { 276 set new 1 277 } 278 default { 279 set style $key 280 } 281 } 282 continue 283 } 284 if {!$isNL} { 285 .t insert end " " $style 286 } 287 set isNL 0 288 .t insert end [mc $line] $style 289 } 290} 291 292addFormattedText { 293 @@title Tk Widget Demonstrations 294 295 This application provides a front end for several short scripts 296 that demonstrate what you can do with Tk widgets. Each of the 297 numbered lines below describes a demonstration; you can click on 298 it to invoke the demonstration. Once the demonstration window 299 appears, you can click the 300 @@bold 301 See Code 302 @@normal 303 button to see the Tcl/Tk code that created the demonstration. If 304 you wish, you can edit the code and click the 305 @@bold 306 Rerun Demo 307 @@normal 308 button in the code window to reinvoke the demonstration with the 309 modified code. 310 @@newline 311 312 @@subtitle Labels, buttons, checkbuttons, and radiobuttons 313 @@demo label Labels (text and bitmaps) 314 @@demo unicodeout Labels and UNICODE text 315 @@demo button Buttons 316 @@demo check Check-buttons (select any of a group) 317 @@demo radio Radio-buttons (select one of a group) 318 @@demo puzzle A 15-puzzle game made out of buttons 319 @@demo icon Iconic buttons that use bitmaps 320 @@demo image1 Two labels displaying images 321 @@demo image2 A simple user interface for viewing images 322 @@demo labelframe Labelled frames 323 @@new 324 @@demo ttkbut The simple Themed Tk widgets 325 326 @@subtitle Listboxes and Trees 327 @@demo states The 50 states 328 @@demo colors Colors: change the color scheme for the application 329 @@demo sayings A collection of famous and infamous sayings 330 @@new 331 @@demo mclist A multi-column list of countries 332 @@new 333 @@demo tree A directory browser tree 334 335 @@subtitle Entries, Spin-boxes and Combo-boxes 336 @@demo entry1 Entries without scrollbars 337 @@demo entry2 Entries with scrollbars 338 @@demo entry3 Validated entries and password fields 339 @@demo spin Spin-boxes 340 @@new 341 @@demo combo Combo-boxes 342 @@demo form Simple Rolodex-like form 343 344 @@subtitle Text 345 @@demo text Basic editable text 346 @@demo style Text display styles 347 @@demo bind Hypertext (tag bindings) 348 @@demo twind A text widget with embedded windows and other features 349 @@demo search A search tool built with a text widget 350 @@new 351 @@demo textpeer Peering text widgets 352 353 @@subtitle Canvases 354 @@demo items The canvas item types 355 @@demo plot A simple 2-D plot 356 @@demo ctext Text items in canvases 357 @@demo arrow An editor for arrowheads on canvas lines 358 @@demo ruler A ruler with adjustable tab stops 359 @@demo floor A building floor plan 360 @@demo cscroll A simple scrollable canvas 361 @@new 362 @@demo knightstour A Knight's tour of the chess board 363 364 @@subtitle Scales and Progress Bars 365 @@demo hscale Horizontal scale 366 @@demo vscale Vertical scale 367 @@new 368 @@demo ttkscale Themed scale linked to a label with traces 369 @@new 370 @@demo ttkprogress Progress bar 371 372 @@subtitle Paned Windows and Notebooks 373 @@demo paned1 Horizontal paned window 374 @@demo paned2 Vertical paned window 375 @@new 376 @@demo ttkpane Themed nested panes 377 @@new 378 @@demo ttknote Notebook widget 379 380 @@subtitle Menus and Toolbars 381 @@demo menu Menus and cascades (sub-menus) 382 @@demo menubu Menu-buttons 383 @@new 384 @@demo ttkmenu Themed menu buttons 385 @@new 386 @@demo toolbar Themed toolbar 387 388 @@subtitle Common Dialogs 389 @@demo msgbox Message boxes 390 @@demo filebox File selection dialog 391 @@demo clrpick Color picker 392 393 @@subtitle Animation 394 @@new 395 @@demo anilabel Animated labels 396 @@new 397 @@demo aniwave Animated wave 398 @@new 399 @@demo pendulum Pendulum simulation 400 @@new 401 @@demo goldberg A celebration of Rube Goldberg 402 403 @@subtitle Miscellaneous 404 @@demo bitmap The built-in bitmaps 405 @@demo dialog1 A dialog box with a local grab 406 @@demo dialog2 A dialog box with a global grab 407} 408 409############################################################################## 410 411.t configure -state disabled 412focus .s 413 414# addSeeDismiss -- 415# Add "See Code" and "Dismiss" button frame, with optional "See Vars" 416# 417# Arguments: 418# w - The name of the frame to use. 419 420proc addSeeDismiss {w show {vars {}} {extra {}}} { 421 ## See Code / Dismiss buttons 422 ttk::frame $w 423 ttk::separator $w.sep 424 #ttk::frame $w.sep -height 2 -relief sunken 425 grid $w.sep -columnspan 4 -row 0 -sticky ew -pady 2 426 ttk::button $w.dismiss -text [mc "Dismiss"] \ 427 -image ::img::delete -compound left \ 428 -command [list destroy [winfo toplevel $w]] 429 ttk::button $w.code -text [mc "See Code"] \ 430 -image ::img::view -compound left \ 431 -command [list showCode $show] 432 set buttons [list x $w.code $w.dismiss] 433 if {[llength $vars]} { 434 ttk::button $w.vars -text [mc "See Variables"] \ 435 -image ::img::view -compound left \ 436 -command [concat [list showVars $w.dialog] $vars] 437 set buttons [linsert $buttons 1 $w.vars] 438 } 439 if {$extra ne ""} { 440 set buttons [linsert $buttons 1 [uplevel 1 $extra]] 441 } 442 grid {*}$buttons -padx 4 -pady 4 443 grid columnconfigure $w 0 -weight 1 444 if {[tk windowingsystem] eq "aqua"} { 445 foreach b [lrange $buttons 1 end] {$b configure -takefocus 0} 446 grid configure $w.sep -pady 0 447 grid configure {*}$buttons -pady {10 12} 448 grid configure [lindex $buttons 1] -padx {16 4} 449 grid configure [lindex $buttons end] -padx {4 18} 450 } 451 return $w 452} 453 454# positionWindow -- 455# This procedure is invoked by most of the demos to position a new demo 456# window. 457# 458# Arguments: 459# w - The name of the window to position. 460 461proc positionWindow w { 462 wm geometry $w +300+300 463} 464 465# showVars -- 466# Displays the values of one or more variables in a window, and updates the 467# display whenever any of the variables changes. 468# 469# Arguments: 470# w - Name of new window to create for display. 471# args - Any number of names of variables. 472 473proc showVars {w args} { 474 catch {destroy $w} 475 toplevel $w 476 if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} 477 wm title $w [mc "Variable values"] 478 479 set b [ttk::frame $w.frame] 480 grid $b -sticky news 481 set f [ttk::labelframe $b.title -text [mc "Variable values:"]] 482 foreach var $args { 483 ttk::label $f.n$var -text "$var:" -anchor w 484 ttk::label $f.v$var -textvariable $var -anchor w 485 grid $f.n$var $f.v$var -padx 2 -pady 2 -sticky w 486 } 487 ttk::button $b.ok -text [mc "OK"] \ 488 -command [list destroy $w] -default active 489 bind $w <Return> [list $b.ok invoke] 490 bind $w <Escape> [list $b.ok invoke] 491 492 grid $f -sticky news -padx 4 493 grid $b.ok -sticky e -padx 4 -pady {6 4} 494 if {[tk windowingsystem] eq "aqua"} { 495 $b.ok configure -takefocus 0 496 grid configure $b.ok -pady {10 12} -padx {16 18} 497 grid configure $f -padx 10 -pady {10 0} 498 } 499 grid columnconfig $f 1 -weight 1 500 grid rowconfigure $f 100 -weight 1 501 grid columnconfig $b 0 -weight 1 502 grid rowconfigure $b 0 -weight 1 503 grid columnconfig $w 0 -weight 1 504 grid rowconfigure $w 0 -weight 1 505} 506 507# invoke -- 508# This procedure is called when the user clicks on a demo description. It is 509# responsible for invoking the demonstration. 510# 511# Arguments: 512# index - The index of the character that the user clicked on. 513 514proc invoke index { 515 global tk_demoDirectory 516 set tags [.t tag names $index] 517 set i [lsearch -glob $tags demo-*] 518 if {$i < 0} { 519 return 520 } 521 set cursor [.t cget -cursor] 522 .t configure -cursor [::ttk::cursor busy] 523 update 524 set demo [string range [lindex $tags $i] 5 end] 525 uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]] 526 update 527 .t configure -cursor $cursor 528 529 .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" 530} 531 532# showStatus -- 533# 534# Show the name of the demo program in the status bar. This procedure is 535# called when the user moves the cursor over a demo description. 536# 537proc showStatus index { 538 set tags [.t tag names $index] 539 set i [lsearch -glob $tags demo-*] 540 set cursor [.t cget -cursor] 541 if {$i < 0} { 542 .statusBar.lab config -text " " 543 set newcursor [::ttk::cursor text] 544 } else { 545 set demo [string range [lindex $tags $i] 5 end] 546 .statusBar.lab config -text [mc "Run the \"%s\" sample program" $demo] 547 set newcursor [::ttk::cursor link] 548 } 549 if {$cursor ne $newcursor} { 550 .t config -cursor $newcursor 551 } 552} 553 554# evalShowCode -- 555# 556# Arguments: 557# w - Name of text widget containing code to eval 558 559proc evalShowCode {w} { 560 set code [$w get 1.0 end-1c] 561 uplevel #0 $code 562} 563 564# showCode -- 565# This procedure creates a toplevel window that displays the code for a 566# demonstration and allows it to be edited and reinvoked. 567# 568# Arguments: 569# w - The name of the demonstration's window, which can be used to 570# derive the name of the file containing its code. 571 572proc showCode w { 573 global tk_demoDirectory 574 set file [string range $w 1 end].tcl 575 set top .code 576 if {![winfo exists $top]} { 577 toplevel $top 578 if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog} 579 580 set t [frame $top.f] 581 set text [text $t.text -font fixedFont -height 24 -wrap word \ 582 -xscrollcommand [list $t.xscroll set] \ 583 -yscrollcommand [list $t.yscroll set] \ 584 -setgrid 1 -highlightthickness 0 -pady 2 -padx 3] 585 scrollbar $t.xscroll -command [list $t.text xview] -orient horizontal 586 scrollbar $t.yscroll -command [list $t.text yview] -orient vertical 587 588 grid $t.text $t.yscroll -sticky news 589 #grid $t.xscroll 590 grid rowconfigure $t 0 -weight 1 591 grid columnconfig $t 0 -weight 1 592 593 set btns [ttk::frame $top.btns] 594 ttk::separator $btns.sep 595 grid $btns.sep -columnspan 4 -row 0 -sticky ew -pady 2 596 ttk::button $btns.dismiss -text [mc "Dismiss"] \ 597 -default active -command [list destroy $top] \ 598 -image ::img::delete -compound left 599 ttk::button $btns.print -text [mc "Print Code"] \ 600 -command [list printCode $text $file] \ 601 -image ::img::print -compound left 602 ttk::button $btns.rerun -text [mc "Rerun Demo"] \ 603 -command [list evalShowCode $text] \ 604 -image ::img::refresh -compound left 605 set buttons [list x $btns.rerun $btns.print $btns.dismiss] 606 grid {*}$buttons -padx 4 -pady 4 607 grid columnconfigure $btns 0 -weight 1 608 if {[tk windowingsystem] eq "aqua"} { 609 foreach b [lrange $buttons 1 end] {$b configure -takefocus 0} 610 grid configure $btns.sep -pady 0 611 grid configure {*}$buttons -pady {10 12} 612 grid configure [lindex $buttons 1] -padx {16 4} 613 grid configure [lindex $buttons end] -padx {4 18} 614 } 615 grid $t -sticky news 616 grid $btns -sticky ew 617 grid rowconfigure $top 0 -weight 1 618 grid columnconfig $top 0 -weight 1 619 620 bind $top <Return> { 621 if {[winfo class %W] ne "Text"} { .code.btns.dismiss invoke } 622 } 623 bind $top <Escape> [bind $top <Return>] 624 } else { 625 wm deiconify $top 626 raise $top 627 } 628 wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]] 629 wm iconname $top $file 630 set id [open [file join $tk_demoDirectory $file]] 631 $top.f.text delete 1.0 end 632 $top.f.text insert 1.0 [read $id] 633 $top.f.text mark set insert 1.0 634 close $id 635} 636 637# printCode -- 638# Prints the source code currently displayed in the See Code dialog. Much 639# thanks to Arjen Markus for this. 640# 641# Arguments: 642# w - Name of text widget containing code to print 643# file - Name of the original file (implicitly for title) 644 645proc printCode {w file} { 646 set code [$w get 1.0 end-1c] 647 648 set dir "." 649 if {[info exists ::env(HOME)]} { 650 set dir "$::env(HOME)" 651 } 652 if {[info exists ::env(TMP)]} { 653 set dir $::env(TMP) 654 } 655 if {[info exists ::env(TEMP)]} { 656 set dir $::env(TEMP) 657 } 658 659 set filename [file join $dir "tkdemo-$file"] 660 set outfile [open $filename "w"] 661 puts $outfile $code 662 close $outfile 663 664 switch -- $::tcl_platform(platform) { 665 unix { 666 if {[catch {exec lp -c $filename} msg]} { 667 tk_messageBox -title "Print spooling failure" \ 668 -message "Print spooling probably failed: $msg" 669 } 670 } 671 windows { 672 if {[catch {PrintTextWin32 $filename} msg]} { 673 tk_messageBox -title "Print spooling failure" \ 674 -message "Print spooling probably failed: $msg" 675 } 676 } 677 default { 678 tk_messageBox -title "Operation not Implemented" \ 679 -message "Wow! Unknown platform: $::tcl_platform(platform)" 680 } 681 } 682 683 # 684 # Be careful to throw away the temporary file in a gentle manner ... 685 # 686 if {[file exists $filename]} { 687 catch {file delete $filename} 688 } 689} 690 691# PrintTextWin32 -- 692# Print a file under Windows using all the "intelligence" necessary 693# 694# Arguments: 695# filename - Name of the file 696# 697# Note: 698# Taken from the Wiki page by Keith Vetter, "Printing text files under 699# Windows". 700# Note: 701# Do not execute the command in the background: that way we can dispose of the 702# file smoothly. 703# 704proc PrintTextWin32 {filename} { 705 package require registry 706 set app [auto_execok notepad.exe] 707 set pcmd "$app /p %1" 708 catch { 709 set app [registry get {HKEY_CLASSES_ROOT\.txt} {}] 710 set pcmd [registry get \ 711 {HKEY_CLASSES_ROOT\\$app\\shell\\print\\command} {}] 712 } 713 714 regsub -all {%1} $pcmd $filename pcmd 715 puts $pcmd 716 717 regsub -all {\\} $pcmd {\\\\} pcmd 718 set command "[auto_execok start] /min $pcmd" 719 eval exec $command 720} 721 722# tkAboutDialog -- 723# 724# Pops up a message box with an "about" message 725# 726proc tkAboutDialog {} { 727 tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \ 728 -message [mc "Tk widget demonstration application"] -detail \ 729"[mc {Copyright (c) %s} {1996-1997 Sun Microsystems, Inc.}] 730[mc {Copyright (c) %s} {1997-2000 Ajuba Solutions, Inc.}] 731[mc {Copyright (c) %s} {2001-2007 Donal K. Fellows}] 732[mc {Copyright (c) %s} {2002-2007 Daniel A. Steffen}]" 733} 734 735# Local Variables: 736# mode: tcl 737# End: 738
