|
|
#!/bin/sh
|
|
|
# the next line restarts using wish \
|
|
|
exec wish "$0" ${1+"$@"}
|
|
|
|
|
|
# widget --
|
|
|
# This script demonstrates the various widgets provided by Tk, along with many
|
|
|
# of the features of the Tk toolkit. This file only contains code to generate
|
|
|
# the main window for the application, which invokes individual
|
|
|
# demonstrations. The code for the actual demonstrations is contained in
|
|
|
# separate ".tcl" files is this directory, which are sourced by this script as
|
|
|
# needed.
|
|
|
|
|
|
package require Tk 8.5
|
|
|
package require msgcat
|
|
|
|
|
|
eval destroy [winfo child .]
|
|
|
set tk_demoDirectory [file join [pwd] [file dirname [info script]]]
|
|
|
::msgcat::mcload $tk_demoDirectory
|
|
|
namespace import ::msgcat::mc
|
|
|
wm title . [mc "Widget Demonstration"]
|
|
|
if {[tk windowingsystem] eq "x11"} {
|
|
|
# This won't work everywhere, but there's no other way in core Tk at the
|
|
|
# moment to display a coloured icon.
|
|
|
image create photo TclPowered \
|
|
|
-file [file join $tk_library images logo64.gif]
|
|
|
wm iconwindow . [toplevel ._iconWindow]
|
|
|
pack [label ._iconWindow.i -image TclPowered]
|
|
|
wm iconname . [mc "tkWidgetDemo"]
|
|
|
}
|
|
|
|
|
|
if {"defaultFont" ni [font names]} {
|
|
|
# TIP #145 defines some standard named fonts
|
|
|
if {"TkDefaultFont" in [font names] && "TkFixedFont" in [font names]} {
|
|
|
# FIX ME: the following technique of cloning the font to copy it works
|
|
|
# fine but means that if the system font is changed by Tk
|
|
|
# cannot update the copied font. font alias might be useful
|
|
|
# here -- or fix the app to use TkDefaultFont etc.
|
|
|
font create mainFont {*}[font configure TkDefaultFont]
|
|
|
font create fixedFont {*}[font configure TkFixedFont]
|
|
|
font create boldFont {*}[font configure TkDefaultFont] -weight bold
|
|
|
font create titleFont {*}[font configure TkDefaultFont] -weight bold
|
|
|
font create statusFont {*}[font configure TkDefaultFont]
|
|
|
font create varsFont {*}[font configure TkDefaultFont]
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
font configure titleFont -size 17
|
|
|
}
|
|
|
} else {
|
|
|
font create mainFont -family Helvetica -size 12
|
|
|
font create fixedFont -family Courier -size 10
|
|
|
font create boldFont -family Helvetica -size 12 -weight bold
|
|
|
font create titleFont -family Helvetica -size 18 -weight bold
|
|
|
font create statusFont -family Helvetica -size 10
|
|
|
font create varsFont -family Helvetica -size 14
|
|
|
}
|
|
|
}
|
|
|
|
|
|
set widgetDemo 1
|
|
|
set font mainFont
|
|
|
|
|
|
image create photo ::img::refresh -format GIF -data {
|
|
|
R0lGODlhEAAQAJEDAP///wAAACpnKv///yH5BAEAAAMALAAAAAAQABAAAAI63IKp
|
|
|
xgcPH2ouwgBCw1HIxHCQ4F3hSJKmwZXqWrmWxj7lKJ2dndcon9EBUq+gz3brVXAR
|
|
|
2tICU0gXBQA7
|
|
|
}
|
|
|
|
|
|
image create photo ::img::view -format GIF -data {
|
|
|
R0lGODlhEAAQAKIHAP///wwMDAAAAMDAwNnZ2SYmJmZmZv///yH5BAEAAAcALAAA
|
|
|
AAAQABAAAANMKLos90+ASamDRxJCgw9YVnlDOXiQBgRDBRgHKE6sW8QR3doPKK27
|
|
|
yg33q/GIOhdg6OsEJzeZykiBSUcs06e56Xx6np8ScIkFGuhQAgA7
|
|
|
}
|
|
|
|
|
|
image create photo ::img::delete -format GIF -data {
|
|
|
R0lGODlhEAAQAIABAIQAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjI+pmwAc3HGy
|
|
|
PUSvqYpuvWQg40FfSVacBa5nN6JYDI3mzRQAOw==
|
|
|
}
|
|
|
|
|
|
image create photo ::img::print -format GIF -data {
|
|
|
R0lGODlhEAAQALMKAAAAAP///52VunNkl8C82Yl+qldBgq+pyrOzs1fYAP///wAA
|
|
|
AAAAAAAAAAAAAAAAACH5BAEAAAoALAAAAAAQABAAAARGUMlJKwU4AztB+ODGeUiJ
|
|
|
fGLlgeEYmGWQXmx7aXgmAUTv/74N4EAsGhOJg1DAbDqbwoJ0Sp0KB9isNis0eL/g
|
|
|
ryhH5pgnEQA7
|
|
|
}
|
|
|
|
|
|
# Note that this is run through the message catalog! This is because this is
|
|
|
# actually an image of a word.
|
|
|
image create photo ::img::new -format GIF -data [mc {
|
|
|
R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3
|
|
|
d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw
|
|
|
nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM
|
|
|
wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1
|
|
|
MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7
|
|
|
}]
|
|
|
|
|
|
#----------------------------------------------------------------
|
|
|
# The code below create the main window, consisting of a menu bar and a text
|
|
|
# widget that explains how to use the program, plus lists all of the demos as
|
|
|
# hypertext items.
|
|
|
#----------------------------------------------------------------
|
|
|
|
|
|
menu .menuBar -tearoff 0
|
|
|
|
|
|
if {[tk windowingsystem] ne "aqua"} {
|
|
|
# This is a tk-internal procedure to make i18n easier
|
|
|
::tk::AmpMenuArgs .menuBar add cascade -label [mc "&File"] \
|
|
|
-menu .menuBar.file
|
|
|
menu .menuBar.file -tearoff 0
|
|
|
::tk::AmpMenuArgs .menuBar.file add command -label [mc "&About..."] \
|
|
|
-command {tkAboutDialog} -accelerator [mc "<F1>"]
|
|
|
bind . <F1> {tkAboutDialog}
|
|
|
.menuBar.file add sep
|
|
|
if {[string match win* [tk windowingsystem]]} {
|
|
|
# Windows doesn't usually have a Meta key
|
|
|
::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \
|
|
|
-command {exit} -accelerator [mc "Ctrl+Q"]
|
|
|
bind . <[mc "Control-q"]> {exit}
|
|
|
} else {
|
|
|
::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \
|
|
|
-command {exit} -accelerator [mc "Meta-Q"]
|
|
|
bind . <[mc "Meta-q"]> {exit}
|
|
|
}
|
|
|
}
|
|
|
|
|
|
. configure -menu .menuBar
|
|
|
|
|
|
ttk::frame .statusBar
|
|
|
ttk::label .statusBar.lab -text " " -anchor w
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
ttk::separator .statusBar.sep
|
|
|
pack .statusBar.sep -side top -expand yes -fill x -pady 0
|
|
|
}
|
|
|
pack .statusBar.lab -side left -padx 2 -expand yes -fill both
|
|
|
if {[tk windowingsystem] ne "aqua"} {
|
|
|
ttk::sizegrip .statusBar.foo
|
|
|
pack .statusBar.foo -side left -padx 2
|
|
|
}
|
|
|
pack .statusBar -side bottom -fill x -pady 2
|
|
|
|
|
|
set textheight 30
|
|
|
catch {
|
|
|
set textheight [expr {
|
|
|
([winfo screenheight .] * 0.7) /
|
|
|
[font metrics mainFont -displayof . -linespace]
|
|
|
}]
|
|
|
}
|
|
|
|
|
|
ttk::frame .textFrame
|
|
|
ttk::scrollbar .s -orient vertical -command {.t yview} -takefocus 1
|
|
|
pack .s -in .textFrame -side right -fill y
|
|
|
text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \
|
|
|
-font mainFont -setgrid 1 -highlightthickness 0 \
|
|
|
-padx 4 -pady 2 -takefocus 0
|
|
|
pack .t -in .textFrame -expand y -fill both -padx 1
|
|
|
pack .textFrame -expand yes -fill both
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
pack configure .statusBar.lab -padx {10 18} -pady {4 6}
|
|
|
pack configure .statusBar -pady 0
|
|
|
.t configure -padx 10 -pady 0
|
|
|
}
|
|
|
|
|
|
# Create a bunch of tags to use in the text widget, such as those for section
|
|
|
# titles and demo descriptions. Also define the bindings for tags.
|
|
|
|
|
|
.t tag configure title -font titleFont
|
|
|
.t tag configure subtitle -font titleFont
|
|
|
.t tag configure bold -font boldFont
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
.t tag configure title -spacing1 8
|
|
|
.t tag configure subtitle -spacing3 3
|
|
|
}
|
|
|
|
|
|
# We put some "space" characters to the left and right of each demo
|
|
|
# description so that the descriptions are highlighted only when the mouse
|
|
|
# cursor is right over them (but not when the cursor is to their left or
|
|
|
# right).
|
|
|
#
|
|
|
.t tag configure demospace -lmargin1 1c -lmargin2 1c
|
|
|
|
|
|
if {[winfo depth .] == 1} {
|
|
|
.t tag configure demo -lmargin1 1c -lmargin2 1c \
|
|
|
-underline 1
|
|
|
.t tag configure visited -lmargin1 1c -lmargin2 1c \
|
|
|
-underline 1
|
|
|
.t tag configure hot -background black -foreground white
|
|
|
} else {
|
|
|
.t tag configure demo -lmargin1 1c -lmargin2 1c \
|
|
|
-foreground blue -underline 1
|
|
|
.t tag configure visited -lmargin1 1c -lmargin2 1c \
|
|
|
-foreground #303080 -underline 1
|
|
|
.t tag configure hot -foreground red -underline 1
|
|
|
}
|
|
|
.t tag bind demo <ButtonRelease-1> {
|
|
|
invoke [.t index {@%x,%y}]
|
|
|
}
|
|
|
set lastLine ""
|
|
|
.t tag bind demo <Enter> {
|
|
|
set lastLine [.t index {@%x,%y linestart}]
|
|
|
.t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars"
|
|
|
.t config -cursor [::ttk::cursor link]
|
|
|
showStatus [.t index {@%x,%y}]
|
|
|
}
|
|
|
.t tag bind demo <Leave> {
|
|
|
.t tag remove hot 1.0 end
|
|
|
.t config -cursor [::ttk::cursor text]
|
|
|
.statusBar.lab config -text ""
|
|
|
}
|
|
|
.t tag bind demo <Motion> {
|
|
|
set newLine [.t index {@%x,%y linestart}]
|
|
|
if {$newLine ne $lastLine} {
|
|
|
.t tag remove hot 1.0 end
|
|
|
set lastLine $newLine
|
|
|
|
|
|
set tags [.t tag names {@%x,%y}]
|
|
|
set i [lsearch -glob $tags demo-*]
|
|
|
if {$i >= 0} {
|
|
|
.t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars"
|
|
|
}
|
|
|
}
|
|
|
showStatus [.t index {@%x,%y}]
|
|
|
}
|
|
|
|
|
|
##############################################################################
|
|
|
# Create the text for the text widget.
|
|
|
|
|
|
# addFormattedText --
|
|
|
#
|
|
|
# Add formatted text (but not hypertext) to the text widget after first
|
|
|
# passing it through the message catalog to allow for localization.
|
|
|
# Lines starting with @@ are formatting directives (insert title, insert
|
|
|
# demo hyperlink, begin newline, or change style) and all other lines
|
|
|
# are literal strings to be inserted. Substitutions are performed,
|
|
|
# allowing processing pieces through the message catalog. Blank lines
|
|
|
# are ignored.
|
|
|
#
|
|
|
proc addFormattedText {formattedText} {
|
|
|
set style normal
|
|
|
set isNL 1
|
|
|
set demoCount 0
|
|
|
set new 0
|
|
|
foreach line [split $formattedText \n] {
|
|
|
set line [string trim $line]
|
|
|
if {$line eq ""} {
|
|
|
continue
|
|
|
}
|
|
|
if {[string match @@* $line]} {
|
|
|
set data [string range $line 2 end]
|
|
|
set key [lindex $data 0]
|
|
|
set values [lrange $data 1 end]
|
|
|
switch -exact -- $key {
|
|
|
title {
|
|
|
.t insert end [mc $values]\n title \n normal
|
|
|
}
|
|
|
newline {
|
|
|
.t insert end \n $style
|
|
|
set isNL 1
|
|
|
}
|
|
|
subtitle {
|
|
|
.t insert end "\n" {} [mc $values] subtitle \
|
|
|
" \n " demospace
|
|
|
set demoCount 0
|
|
|
}
|
|
|
demo {
|
|
|
set description [lassign $values name]
|
|
|
.t insert end "[incr demoCount]. [mc $description]" \
|
|
|
[list demo demo-$name]
|
|
|
if {$new} {
|
|
|
.t image create end -image ::img::new -padx 5
|
|
|
set new 0
|
|
|
}
|
|
|
.t insert end " \n " demospace
|
|
|
}
|
|
|
new {
|
|
|
set new 1
|
|
|
}
|
|
|
default {
|
|
|
set style $key
|
|
|
}
|
|
|
}
|
|
|
continue
|
|
|
}
|
|
|
if {!$isNL} {
|
|
|
.t insert end " " $style
|
|
|
}
|
|
|
set isNL 0
|
|
|
.t insert end [mc $line] $style
|
|
|
}
|
|
|
}
|
|
|
|
|
|
addFormattedText {
|
|
|
@@title Tk Widget Demonstrations
|
|
|
|
|
|
This application provides a front end for several short scripts
|
|
|
that demonstrate what you can do with Tk widgets. Each of the
|
|
|
numbered lines below describes a demonstration; you can click on
|
|
|
it to invoke the demonstration. Once the demonstration window
|
|
|
appears, you can click the
|
|
|
@@bold
|
|
|
See Code
|
|
|
@@normal
|
|
|
button to see the Tcl/Tk code that created the demonstration. If
|
|
|
you wish, you can edit the code and click the
|
|
|
@@bold
|
|
|
Rerun Demo
|
|
|
@@normal
|
|
|
button in the code window to reinvoke the demonstration with the
|
|
|
modified code.
|
|
|
@@newline
|
|
|
|
|
|
@@subtitle Labels, buttons, checkbuttons, and radiobuttons
|
|
|
@@demo label Labels (text and bitmaps)
|
|
|
@@demo unicodeout Labels and UNICODE text
|
|
|
@@demo button Buttons
|
|
|
@@demo check Check-buttons (select any of a group)
|
|
|
@@demo radio Radio-buttons (select one of a group)
|
|
|
@@demo puzzle A 15-puzzle game made out of buttons
|
|
|
@@demo icon Iconic buttons that use bitmaps
|
|
|
@@demo image1 Two labels displaying images
|
|
|
@@demo image2 A simple user interface for viewing images
|
|
|
@@demo labelframe Labelled frames
|
|
|
@@demo ttkbut The simple Themed Tk widgets
|
|
|
|
|
|
@@subtitle Listboxes and Trees
|
|
|
@@demo states The 50 states
|
|
|
@@demo colors Colors: change the color scheme for the application
|
|
|
@@demo sayings A collection of famous and infamous sayings
|
|
|
@@demo mclist A multi-column list of countries
|
|
|
@@demo tree A directory browser tree
|
|
|
|
|
|
@@subtitle Entries, Spin-boxes and Combo-boxes
|
|
|
@@demo entry1 Entries without scrollbars
|
|
|
@@demo entry2 Entries with scrollbars
|
|
|
@@demo entry3 Validated entries and password fields
|
|
|
@@demo spin Spin-boxes
|
|
|
@@demo combo Combo-boxes
|
|
|
@@demo form Simple Rolodex-like form
|
|
|
|
|
|
@@subtitle Text
|
|
|
@@demo text Basic editable text
|
|
|
@@demo style Text display styles
|
|
|
@@demo bind Hypertext (tag bindings)
|
|
|
@@demo twind A text widget with embedded windows and other features
|
|
|
@@demo search A search tool built with a text widget
|
|
|
@@demo textpeer Peering text widgets
|
|
|
|
|
|
@@subtitle Canvases
|
|
|
@@demo items The canvas item types
|
|
|
@@demo plot A simple 2-D plot
|
|
|
@@demo ctext Text items in canvases
|
|
|
@@demo arrow An editor for arrowheads on canvas lines
|
|
|
@@demo ruler A ruler with adjustable tab stops
|
|
|
@@demo floor A building floor plan
|
|
|
@@demo cscroll A simple scrollable canvas
|
|
|
@@demo knightstour A Knight's tour of the chess board
|
|
|
|
|
|
@@subtitle Scales and Progress Bars
|
|
|
@@demo hscale Horizontal scale
|
|
|
@@demo vscale Vertical scale
|
|
|
@@new
|
|
|
@@demo ttkscale Themed scale linked to a label with traces
|
|
|
@@demo ttkprogress Progress bar
|
|
|
|
|
|
@@subtitle Paned Windows and Notebooks
|
|
|
@@demo paned1 Horizontal paned window
|
|
|
@@demo paned2 Vertical paned window
|
|
|
@@demo ttkpane Themed nested panes
|
|
|
@@demo ttknote Notebook widget
|
|
|
|
|
|
@@subtitle Menus and Toolbars
|
|
|
@@demo menu Menus and cascades (sub-menus)
|
|
|
@@demo menubu Menu-buttons
|
|
|
@@demo ttkmenu Themed menu buttons
|
|
|
@@demo toolbar Themed toolbar
|
|
|
|
|
|
@@subtitle Common Dialogs
|
|
|
@@demo msgbox Message boxes
|
|
|
@@demo filebox File selection dialog
|
|
|
@@demo clrpick Color picker
|
|
|
@@demo fontchoose Font selection dialog
|
|
|
|
|
|
@@subtitle Animation
|
|
|
@@demo anilabel Animated labels
|
|
|
@@demo aniwave Animated wave
|
|
|
@@demo pendulum Pendulum simulation
|
|
|
@@demo goldberg A celebration of Rube Goldberg
|
|
|
|
|
|
@@subtitle Miscellaneous
|
|
|
@@demo bitmap The built-in bitmaps
|
|
|
@@demo dialog1 A dialog box with a local grab
|
|
|
@@demo dialog2 A dialog box with a global grab
|
|
|
}
|
|
|
|
|
|
##############################################################################
|
|
|
|
|
|
.t configure -state disabled
|
|
|
focus .s
|
|
|
|
|
|
# addSeeDismiss --
|
|
|
# Add "See Code" and "Dismiss" button frame, with optional "See Vars"
|
|
|
#
|
|
|
# Arguments:
|
|
|
# w - The name of the frame to use.
|
|
|
|
|
|
proc addSeeDismiss {w show {vars {}} {extra {}}} {
|
|
|
## See Code / Dismiss buttons
|
|
|
ttk::frame $w
|
|
|
ttk::separator $w.sep
|
|
|
#ttk::frame $w.sep -height 2 -relief sunken
|
|
|
grid $w.sep -columnspan 4 -row 0 -sticky ew -pady 2
|
|
|
ttk::button $w.dismiss -text [mc "Dismiss"] \
|
|
|
-image ::img::delete -compound left \
|
|
|
-command [list destroy [winfo toplevel $w]]
|
|
|
ttk::button $w.code -text [mc "See Code"] \
|
|
|
-image ::img::view -compound left \
|
|
|
-command [list showCode $show]
|
|
|
set buttons [list x $w.code $w.dismiss]
|
|
|
if {[llength $vars]} {
|
|
|
ttk::button $w.vars -text [mc "See Variables"] \
|
|
|
-image ::img::view -compound left \
|
|
|
-command [concat [list showVars $w.dialog] $vars]
|
|
|
set buttons [linsert $buttons 1 $w.vars]
|
|
|
}
|
|
|
if {$extra ne ""} {
|
|
|
set buttons [linsert $buttons 1 [uplevel 1 $extra]]
|
|
|
}
|
|
|
grid {*}$buttons -padx 4 -pady 4
|
|
|
grid columnconfigure $w 0 -weight 1
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
foreach b [lrange $buttons 1 end] {$b configure -takefocus 0}
|
|
|
grid configure $w.sep -pady 0
|
|
|
grid configure {*}$buttons -pady {10 12}
|
|
|
grid configure [lindex $buttons 1] -padx {16 4}
|
|
|
grid configure [lindex $buttons end] -padx {4 18}
|
|
|
}
|
|
|
return $w
|
|
|
}
|
|
|
|
|
|
# positionWindow --
|
|
|
# This procedure is invoked by most of the demos to position a new demo
|
|
|
# window.
|
|
|
#
|
|
|
# Arguments:
|
|
|
# w - The name of the window to position.
|
|
|
|
|
|
proc positionWindow w {
|
|
|
wm geometry $w +300+300
|
|
|
}
|
|
|
|
|
|
# showVars --
|
|
|
# Displays the values of one or more variables in a window, and updates the
|
|
|
# display whenever any of the variables changes.
|
|
|
#
|
|
|
# Arguments:
|
|
|
# w - Name of new window to create for display.
|
|
|
# args - Any number of names of variables.
|
|
|
|
|
|
proc showVars {w args} {
|
|
|
catch {destroy $w}
|
|
|
toplevel $w
|
|
|
if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
|
|
|
wm title $w [mc "Variable values"]
|
|
|
|
|
|
set b [ttk::frame $w.frame]
|
|
|
grid $b -sticky news
|
|
|
set f [ttk::labelframe $b.title -text [mc "Variable values:"]]
|
|
|
foreach var $args {
|
|
|
ttk::label $f.n$var -text "$var:" -anchor w
|
|
|
ttk::label $f.v$var -textvariable $var -anchor w
|
|
|
grid $f.n$var $f.v$var -padx 2 -pady 2 -sticky w
|
|
|
}
|
|
|
ttk::button $b.ok -text [mc "OK"] \
|
|
|
-command [list destroy $w] -default active
|
|
|
bind $w <Return> [list $b.ok invoke]
|
|
|
bind $w <Escape> [list $b.ok invoke]
|
|
|
|
|
|
grid $f -sticky news -padx 4
|
|
|
grid $b.ok -sticky e -padx 4 -pady {6 4}
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
$b.ok configure -takefocus 0
|
|
|
grid configure $b.ok -pady {10 12} -padx {16 18}
|
|
|
grid configure $f -padx 10 -pady {10 0}
|
|
|
}
|
|
|
grid columnconfig $f 1 -weight 1
|
|
|
grid rowconfigure $f 100 -weight 1
|
|
|
grid columnconfig $b 0 -weight 1
|
|
|
grid rowconfigure $b 0 -weight 1
|
|
|
grid columnconfig $w 0 -weight 1
|
|
|
grid rowconfigure $w 0 -weight 1
|
|
|
}
|
|
|
|
|
|
# invoke --
|
|
|
# This procedure is called when the user clicks on a demo description. It is
|
|
|
# responsible for invoking the demonstration.
|
|
|
#
|
|
|
# Arguments:
|
|
|
# index - The index of the character that the user clicked on.
|
|
|
|
|
|
proc invoke index {
|
|
|
global tk_demoDirectory
|
|
|
set tags [.t tag names $index]
|
|
|
set i [lsearch -glob $tags demo-*]
|
|
|
if {$i < 0} {
|
|
|
return
|
|
|
}
|
|
|
set cursor [.t cget -cursor]
|
|
|
.t configure -cursor [::ttk::cursor busy]
|
|
|
update
|
|
|
set demo [string range [lindex $tags $i] 5 end]
|
|
|
uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]]
|
|
|
update
|
|
|
.t configure -cursor $cursor
|
|
|
|
|
|
.t tag add visited "$index linestart +1 chars" "$index lineend -1 chars"
|
|
|
}
|
|
|
|
|
|
# showStatus --
|
|
|
#
|
|
|
# Show the name of the demo program in the status bar. This procedure is
|
|
|
# called when the user moves the cursor over a demo description.
|
|
|
#
|
|
|
proc showStatus index {
|
|
|
set tags [.t tag names $index]
|
|
|
set i [lsearch -glob $tags demo-*]
|
|
|
set cursor [.t cget -cursor]
|
|
|
if {$i < 0} {
|
|
|
.statusBar.lab config -text " "
|
|
|
set newcursor [::ttk::cursor text]
|
|
|
} else {
|
|
|
set demo [string range [lindex $tags $i] 5 end]
|
|
|
.statusBar.lab config -text [mc "Run the \"%s\" sample program" $demo]
|
|
|
set newcursor [::ttk::cursor link]
|
|
|
}
|
|
|
if {$cursor ne $newcursor} {
|
|
|
.t config -cursor $newcursor
|
|
|
}
|
|
|
}
|
|
|
|
|
|
# evalShowCode --
|
|
|
#
|
|
|
# Arguments:
|
|
|
# w - Name of text widget containing code to eval
|
|
|
|
|
|
proc evalShowCode {w} {
|
|
|
set code [$w get 1.0 end-1c]
|
|
|
uplevel #0 $code
|
|
|
}
|
|
|
|
|
|
# showCode --
|
|
|
# This procedure creates a toplevel window that displays the code for a
|
|
|
# demonstration and allows it to be edited and reinvoked.
|
|
|
#
|
|
|
# Arguments:
|
|
|
# w - The name of the demonstration's window, which can be used to
|
|
|
# derive the name of the file containing its code.
|
|
|
|
|
|
proc showCode w {
|
|
|
global tk_demoDirectory
|
|
|
set file [string range $w 1 end].tcl
|
|
|
set top .code
|
|
|
if {![winfo exists $top]} {
|
|
|
toplevel $top
|
|
|
if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog}
|
|
|
|
|
|
set t [frame $top.f]
|
|
|
set text [text $t.text -font fixedFont -height 24 -wrap word \
|
|
|
-xscrollcommand [list $t.xscroll set] \
|
|
|
-yscrollcommand [list $t.yscroll set] \
|
|
|
-setgrid 1 -highlightthickness 0 -pady 2 -padx 3]
|
|
|
ttk::scrollbar $t.xscroll -command [list $t.text xview] \
|
|
|
-orient horizontal
|
|
|
ttk::scrollbar $t.yscroll -command [list $t.text yview] \
|
|
|
-orient vertical
|
|
|
|
|
|
grid $t.text $t.yscroll -sticky news
|
|
|
#grid $t.xscroll
|
|
|
grid rowconfigure $t 0 -weight 1
|
|
|
grid columnconfig $t 0 -weight 1
|
|
|
|
|
|
set btns [ttk::frame $top.btns]
|
|
|
ttk::separator $btns.sep
|
|
|
grid $btns.sep -columnspan 4 -row 0 -sticky ew -pady 2
|
|
|
ttk::button $btns.dismiss -text [mc "Dismiss"] \
|
|
|
-default active -command [list destroy $top] \
|
|
|
-image ::img::delete -compound left
|
|
|
ttk::button $btns.print -text [mc "Print Code"] \
|
|
|
-command [list printCode $text $file] \
|
|
|
-image ::img::print -compound left
|
|
|
ttk::button $btns.rerun -text [mc "Rerun Demo"] \
|
|
|
-command [list evalShowCode $text] \
|
|
|
-image ::img::refresh -compound left
|
|
|
set buttons [list x $btns.rerun $btns.print $btns.dismiss]
|
|
|
grid {*}$buttons -padx 4 -pady 4
|
|
|
grid columnconfigure $btns 0 -weight 1
|
|
|
if {[tk windowingsystem] eq "aqua"} {
|
|
|
foreach b [lrange $buttons 1 end] {$b configure -takefocus 0}
|
|
|
grid configure $btns.sep -pady 0
|
|
|
grid configure {*}$buttons -pady {10 12}
|
|
|
grid configure [lindex $buttons 1] -padx {16 4}
|
|
|
grid configure [lindex $buttons end] -padx {4 18}
|
|
|
}
|
|
|
grid $t -sticky news
|
|
|
grid $btns -sticky ew
|
|
|
grid rowconfigure $top 0 -weight 1
|
|
|
grid columnconfig $top 0 -weight 1
|
|
|
|
|
|
bind $top <Return> {
|
|
|
if {[winfo class %W] ne "Text"} { .code.btns.dismiss invoke }
|
|
|
}
|
|
|
bind $top <Escape> [bind $top <Return>]
|
|
|
} else {
|
|
|
wm deiconify $top
|
|
|
raise $top
|
|
|
}
|
|
|
wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]]
|
|
|
wm iconname $top $file
|
|
|
set id [open [file join $tk_demoDirectory $file]]
|
|
|
$top.f.text delete 1.0 end
|
|
|
$top.f.text insert 1.0 [read $id]
|
|
|
$top.f.text mark set insert 1.0
|
|
|
close $id
|
|
|
}
|
|
|
|
|
|
# printCode --
|
|
|
# Prints the source code currently displayed in the See Code dialog. Much
|
|
|
# thanks to Arjen Markus for this.
|
|
|
#
|
|
|
# Arguments:
|
|
|
# w - Name of text widget containing code to print
|
|
|
# file - Name of the original file (implicitly for title)
|
|
|
|
|
|
proc printCode {w file} {
|
|
|
set code [$w get 1.0 end-1c]
|
|
|
|
|
|
set dir "."
|
|
|
if {[info exists ::env(HOME)]} {
|
|
|
set dir "$::env(HOME)"
|
|
|
}
|
|
|
if {[info exists ::env(TMP)]} {
|
|
|
set dir $::env(TMP)
|
|
|
}
|
|
|
if {[info exists ::env(TEMP)]} {
|
|
|
set dir $::env(TEMP)
|
|
|
}
|
|
|
|
|
|
set filename [file join $dir "tkdemo-$file"]
|
|
|
set outfile [open $filename "w"]
|
|
|
puts $outfile $code
|
|
|
close $outfile
|
|
|
|
|
|
switch -- $::tcl_platform(platform) {
|
|
|
unix {
|
|
|
if {[catch {exec lp -c $filename} msg]} {
|
|
|
tk_messageBox -title "Print spooling failure" \
|
|
|
-message "Print spooling probably failed: $msg"
|
|
|
}
|
|
|
}
|
|
|
windows {
|
|
|
if {[catch {PrintTextWin32 $filename} msg]} {
|
|
|
tk_messageBox -title "Print spooling failure" \
|
|
|
-message "Print spooling probably failed: $msg"
|
|
|
}
|
|
|
}
|
|
|
default {
|
|
|
tk_messageBox -title "Operation not Implemented" \
|
|
|
-message "Wow! Unknown platform: $::tcl_platform(platform)"
|
|
|
}
|
|
|
}
|
|
|
|
|
|
#
|
|
|
# Be careful to throw away the temporary file in a gentle manner ...
|
|
|
#
|
|
|
if {[file exists $filename]} {
|
|
|
catch {file delete $filename}
|
|
|
}
|
|
|
}
|
|
|
|
|
|
# PrintTextWin32 --
|
|
|
# Print a file under Windows using all the "intelligence" necessary
|
|
|
#
|
|
|
# Arguments:
|
|
|
# filename - Name of the file
|
|
|
#
|
|
|
# Note:
|
|
|
# Taken from the Wiki page by Keith Vetter, "Printing text files under
|
|
|
# Windows".
|
|
|
# Note:
|
|
|
# Do not execute the command in the background: that way we can dispose of the
|
|
|
# file smoothly.
|
|
|
#
|
|
|
proc PrintTextWin32 {filename} {
|
|
|
package require registry
|
|
|
set app [auto_execok notepad.exe]
|
|
|
set pcmd "$app /p %1"
|
|
|
catch {
|
|
|
set app [registry get {HKEY_CLASSES_ROOT\.txt} {}]
|
|
|
set pcmd [registry get \
|
|
|
{HKEY_CLASSES_ROOT\\$app\\shell\\print\\command} {}]
|
|
|
}
|
|
|
|
|
|
regsub -all {%1} $pcmd $filename pcmd
|
|
|
puts $pcmd
|
|
|
|
|
|
regsub -all {\\} $pcmd {\\\\} pcmd
|
|
|
set command "[auto_execok start] /min $pcmd"
|
|
|
eval exec $command
|
|
|
}
|
|
|
|
|
|
# tkAboutDialog --
|
|
|
#
|
|
|
# Pops up a message box with an "about" message
|
|
|
#
|
|
|
proc tkAboutDialog {} {
|
|
|
tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \
|
|
|
-message [mc "Tk widget demonstration application"] -detail \
|
|
|
"[mc "Copyright \u00a9 %s" {1996-1997 Sun Microsystems, Inc.}]
|
|
|
[mc "Copyright \u00a9 %s" {1997-2000 Ajuba Solutions, Inc.}]
|
|
|
[mc "Copyright \u00a9 %s" {2001-2009 Donal K. Fellows}]
|
|
|
[mc "Copyright \u00a9 %s" {2002-2007 Daniel A. Steffen}]"
|
|
|
}
|
|
|
|
|
|
# Local Variables:
|
|
|
# mode: tcl
|
|
|
# End:
|