1#!/usr/bin/env perl
2#
3# This script demonstrates the various widgets provided by Tk, along with many of the features of the Tk toolkit.  This file
4# only contains code to generate the main window for the application, which invokes individual demonstrations.  The code for
5# the actual demonstrations is contained in separate ".pl" files in the directory "widget_lib", which are auto-loaded by Perl
6# when they are needed.  To find the code for a particular demo, look below for the procedure that's invoked by its menu entry,
7# then grep for the file that contains the procedure definition.
8#
9# Tcl/Tk -> Perl translation by Stephen O. Lidie.  lusol@Lehigh.EDU  95/01/08
10
11
12require 5.001;
13
14use Tk;
15use Tk::Dialog;
16use English;
17
18$auto_path = "Tk/demos/widget_lib";
19
20sub AUTOLOAD {
21
22    # This routine handles the loading of most menu button methods.
23
24    my($prefix, $method) = $AUTOLOAD =~ /(.*)::(.+)$/;
25    eval "require \"$auto_path/${method}.pl\"";
26    die $@ if $@;
27    goto &$AUTOLOAD;
28
29} # end AUTOLOAD
30
31
32sub dpos {
33
34    # Position a window at a reasonable place on the screen.
35
36    shift->geometry('+300+300');
37
38} # end dpos
39
40
41sub insert_with_tags {
42
43    # The procedure below inserts text into a given text widget and applies one or more tags to that text.  The arguments are:
44    #
45    # w		Window in which to insert
46    # text	Text to insert (it's inserted at the "insert" mark)
47    # args	One or more tags to apply to text.  If this is empty then all tags are removed from the text.
48
49    my($w, $text, @args) = @_;
50    my($tag, $i, $start);
51
52    $start = $w->index('insert');
53    $w->insert('insert', $text);
54    foreach $tag ($w->tag('names', $start)) {
55	$w->tag('remove', $tag, $start, 'insert');
56    }
57    foreach $i (@args) {
58	$w->tag('add', $i, $start, 'insert');
59    }
60
61} # end insert_with_tags
62
63
64sub lsearch {
65
66    # Search the list using the supplied regular expression and return its ordinal, or -1 if not found.
67
68    my($regexp, @list) = @_;
69    my($i);
70
71    for ($i=0; $i<=$#list; $i++) {
72        return $i if $list[$i] =~ /$regexp/;
73    }
74    return -1;
75
76} # end lsearch
77
78
79sub mkmb {
80
81    # Make a Menubutton widget; note that the menu is automatically created.  We maintain a list of the Menubutton references
82    # since some callers need to refer to the Menubutton, as well as to suppress stray name warnings with Perl -w.
83
84    my($mb_label, $mb_label_underline, $mb_list_ref) = @_;
85
86    my $mb = $menu->Menubutton(-text => $mb_label, -underline => $mb_label_underline);
87    foreach $mb_list (@{$mb_list_ref}) {
88	$mb->command(-label => $mb_list->[0], -command => $mb_list->[1] , -underline => $mb_list->[2]);
89    }
90    $mb->pack(-side => 'left');
91    push @menu_button_list, $mb;
92
93} # end mkmb
94
95
96$top = MainWindow->new;
97$top->title('Widget Demonstration');
98
99# The code below creates the main window, consisting of a menu bar and a message explaining the basic operation of the program.
100
101$menu = $top->Frame(-relief => 'raised', -borderwidth => 1);
102$mess = $top->Message(-font => '-Adobe-times-medium-r-normal--*-180-*-*-*-*-*-*', -relief => 'raised', -width => 500,
103		     -borderwidth => 1, -text => "This application demonstrates the widgets provided by the Tk toolkit.  " .
104		     "The menus above are organized by widget type:  each menu contains one or more demonstrations of a " .
105		     "particular type of widget.  To invoke a demonstration, press mouse button 1 over one of the menu " .
106		     "buttons above, drag the mouse to the desired entry in the menu, then release the mouse button.\n\nTo " .
107		     "exit this demonstration, invoke the \"Quit\" entry in the \"Misc\" menu.");
108
109$menu->pack(-side => 'top', -fill => 'x');
110$mess->pack(-side, 'bottom', -expand => 'yes', -fill => 'both');
111
112# The code below creates all the Dialog objects required by this widget demonstration program.
113
114$DialogRef_bml = $top->Dialog(-title => 'Bitmap menu label');
115
116$DialogRef_bml->Subwidget('message')->configure(-wraplength => '2.5i', -text => 'The menu entry you invoked displays a bitmap ' .
117			  'rather than a text string.  Other than this, it is just like any other menu entry.');
118
119$DialogRef_lg = $top->Dialog(-title => 'Modal dialog (local grab)');
120$DialogRef_lg->Subwidget('message')->configure(-wraplength => '4i', -justify => 'left', -text =>'This dialog box is a modal one.  ' .
121			 'It uses Tk\'s "grab" command to create a "local grab" on the dialog box.  The grab ' .
122			 'prevents any pointer-related events from getting to any other windows in the application.  ' .
123			 'If you press the "OK" button below (or hit the Return key) then the dialog box will go ' .
124			 'away and things will return to normal.');
125
126$DialogRef_gg = $top->Dialog(-title => 'Modal dialog (global grab)');
127$DialogRef_gg->Subwidget('message')->configure(-wraplength => '4i', -text => 'This is another modal dialog box.  However, in this ' .
128		         'case a "global grab" is used, which locks up the display so you can\'t talk to any windows in ' .
129			 'any applications anywhere, except for the dialog.  If you press the "OK" button below (or hit ' .
130			 'the Return key) then the dialog box will go away and things will return to normal.');
131
132# The code below creates all the menus, which invoke procedures to create particular demonstrations of various widgets.
133
134mkmb('Labels_Buttons', 7,
135     [
136      ['Labels',                     \&mkLabel,                                          0],
137      ['Buttons',                    \&mkButton,                                         0],
138      ['Checkbuttons',               \&mkCheck,                                          0],
139      ['Radiobuttons',               \&mkRadio,                                          0],
140      ['15-puzzle',                  \&mkPuzzle,                                         0],
141      ['Iconic buttons',             \&mkIcon,                                           0],
142     ]);
143$menu_button_list[$#menu_button_list]->configure(-text => 'Labels/Buttons');
144
145mkmb('Listboxes',      0,
146     [
147      ['States',                     \&mkListbox,                                        0],
148      ['Colors',                     \&mkListbox2,                                       0],
149      ['Well-known sayings',         \&mkListbox3,                                       0],
150     ]);
151
152mkmb('Entries',        0,
153     [
154      ['Without scrollbars',         \&mkEntry,                                          4],
155      ['With scrollbars',            \&mkEntry2,                                         0],
156      ['Simple form',                \&mkForm,                                           0],
157     ]);
158
159mkmb('Text',           0,
160     [
161      ['Basic text',                 \&mkBasic,                                          0],
162      ['Display styles',             \&mkStyles,                                         0],
163      ['Command bindings',           \&mkTextBind,                                       0],
164      ['Embedded windows',           \&mkTextWind,                                       0],
165      ['Search',                     \&mkTxtSearch,                                     0],
166     ]);
167
168mkmb('Scrollbars',     0,
169     [
170      ['Vertical',                   \&mkListbox2,                                       0],
171      ['Horizontal',                 \&mkEntry2,                                         0],
172     ]);
173
174mkmb('Scales',         2,
175     [
176      ['Vertical',                   \&mkVScale,                                         0],
177      ['Horizontal',                 \&mkHScale,                                         0],
178     ]);
179
180mkmb('Canvases',       0,
181     [
182      ['Item types',                 \&mkItems,                                          0],
183      ['2-D plot',                   \&mkPlot,                                           0],
184      ['Text',                       \&mkCanvText,                                       0],
185      ['Arrow shapes',               \&mkArrow,                                          0],
186      ['Ruler',                      \&mkRuler,                                          0],
187      ['Scrollable canvas',          \&mkScroll,                                         0],
188      ['Floor plan',                 \&mkFloor,                                          0],
189     ]);
190
191$MENUS_HI = 'Print hello';
192$MENUS_BY = 'Print goodbye';
193$MENUS_CB = 'Check buttons';
194$MENUS_RB = 'Radio buttons';
195mkmb('Menus',          0,
196     [
197      [$MENUS_HI,                    sub {print STDOUT "Hello\n"},                       6],
198      [$MENUS_BY,                    sub {print STDOUT "Goodbye\n"},                     6],
199      ['Light blue background',      sub {$mess->configure(-background => 'LightBlue1')}, 0],
200     ]);
201$mess->bind('<Any-Enter>' => sub {shift->focus});
202$mess->bind('<Control-a>' => sub {print STDOUT "Hello\n"});
203$mess->bind('<Control-b>' => sub {print STDOUT "Goodbye\n"});
204my $menus = $menu_button_list[$#menu_button_list]->cget('-menu'); # get Menubutton "Menus" auto-created menu
205$menus->entryconfigure($MENUS_HI, -accelerator => 'Control+a');
206$menus->entryconfigure($MENUS_BY, -accelerator => 'Control+b');
207$menus->cascade(-label => $MENUS_CB, -underline => 0);
208$menus->cascade(-label => $MENUS_RB, -underline => 0);
209$menus->command(-bitmap => '@'.Tk->findINC('demos/images/pattern'), -command => sub {$DialogRef_bml->Show});
210
211my $menus_check = $menus->Menu();
212$menus->entryconfigure($MENUS_CB, -menu => $menus_check);
213$oil = 0;
214$trans = 0;
215$brakes = 0;
216$lights = 0;
217$menus_check->checkbutton(-label => 'Oil checked', -variable => \$oil);
218$menus_check->checkbutton(-label => 'Transmission checked', -variable => \$trans);
219$menus_check->checkbutton(-label => 'Brakes checked', -variable => \$brakes);
220$menus_check->checkbutton(-label => 'Lights checked', -variable => \$lights);
221$menus_check->separator;
222$menus_check->command(-label => 'Show current values', -command => [\&showVars, $top, qw(oil trans brakes lights)]);
223$menus_check->invoke(1);
224$menus_check->invoke(3);
225
226my $menus_radio = $menus->Menu();
227$menus->entryconfigure($MENUS_RB, -menu => $menus_radio);
228$pointSize = 0;
229$style = 'roman';
230$menus_radio->radiobutton(-label => '10 point', -variable => \$pointSize, -value => 10);
231$menus_radio->radiobutton(-label => '14 point', -variable => \$pointSize, -value => 14);
232$menus_radio->radiobutton(-label => '18 point', -variable => \$pointSize, -value => 18);
233$menus_radio->radiobutton(-label => '24 point', -variable => \$pointSize, -value => 24);
234$menus_radio->radiobutton(-label => '32 point', -variable => \$pointSize, -value => 32);
235$menus_radio->separator;
236$menus_radio->radiobutton(-label => 'Roman', -variable => \$style, -value => 'roman');
237$menus_radio->radiobutton(-label => 'Bold', -variable => \$style, -value => 'bold');
238$menus_radio->radiobutton(-label => 'Italic', -variable => \$style, -value => 'italic');
239$menus_radio->separator;
240$menus_radio->command(-label => 'Show current values', -command => [\&showVars, $top, 'pointSize', 'style']);
241$menus_radio->invoke(1);
242$menus_radio->invoke(7);
243
244mkmb('Misc',           1,
245     [
246      ['Modal dialog (local grab)',  sub {$DialogRef_lg->Show},                         14],
247      ['Modal dialog (global grab)', sub {$DialogRef_gg->Show('-global')},              14],
248      ['Built-in bitmaps',           \&mkBitmaps,                                        0],
249      ['Quit', \&exit, 0],
250     ]);
251
252MainLoop;
253