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