1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
#!/usr/bin/env perl
#
# This script was written as an entry in Tom LaStrange's rolodex benchmark.
# It creates something that has some of the look and feel of a rolodex program,# although it's lifeless and doesn't actually do the rolodex application.
#
# Tcl/Tk -> Perl translation by Stephen O. Lidie. lusol@Lehigh.EDU 95/01/16
# This needs a good re-write, but no time now (SOL), 96/01/25.
require 5.002;
use English;
use Tk;
use Tk::Dialog;
#------------------------------------------
# Phase 0: create the front end.
#------------------------------------------
$top = MainWindow->new;
$frame = $top->Frame(-relief => 'flat');
$frame->pack(-side => 'top', -fill => 'y', -anchor => 'center');
@names = ('', 'Name:', 'Address:', '', '', 'Home Phone:', 'Work Phone:', 'Fax:');
foreach $i (1..7) {
# Use symbolic/soft references to create the widget names at object time.
# Also, we need to keep a mapping of widget names to Perl/Tk references
# for the online help to work.
($f,$l,$e) = ("frame_${i}", "frame_${i}_l", "frame_${i}_e");
${$f} = $frame->Frame();
${$f}->pack(-side => 'top', -pady => '2', -anchor => 'e');
${$l} = ${$f}->Label(-text => $names[$i], -anchor => 'e');
${$e} = ${$f}->Entry(-width => '30', -relief => 'sunken');
${$e}->pack(-side => 'right');
${$l}->pack(-side => 'right');
$ref_to_name{$e} = ${$e}; # map Entry widget to its Perl/Tk reference
}
$buttons = $top->Frame();
$buttons->pack(-side => 'bottom', -pady => '2', -anchor => 'center');
$buttons_clear = $buttons->Button(-text => 'Clear');
$buttons_add = $buttons->Button(-text => 'Add');
$buttons_search = $buttons->Button(-text => 'Search');
$buttons_delete = $buttons->Button(-text => 'Delete ...');
$buttons_clear->pack(-side => 'left', -padx => '2');
$buttons_add->pack(-side => 'left', -padx => '2');
$buttons_search->pack(-side => 'left', -padx => '2');
$buttons_delete->pack(-side => 'left', -padx => '2');
#------------------------------------------
# Phase 1: Add menus, dialog boxes
#------------------------------------------
$menu = $top->Frame(-relief => 'raised', -borderwidth => '1');
$menu->pack(-before => $frame, -side => 'top', -fill => 'x');
$menu_file = $menu->Menubutton(-text => 'File', -underline => 0);
$ref_to_name{'menu_file'} = $menu_file;
$menu_file->command(-label => 'load ...', -command => \&fileAction,
-underline => 0);
$menu_file->command(-label => 'Exit', -command => \&exit, -underline => 0);
$menu_file->pack(-side => 'left');
$menu_help = $menu->Menubutton(-text => 'Help', -underline => '0');
$menu_help->pack(-side => 'right');
# Make all the Dialog objects.
$DELACT = $top->Dialog(
-title => 'Confirm Action',
-text => 'Are you sure?',
-bitmap => 'questhead',
-default_button => 'Cancel',
-buttons => ['OK', 'Cancel'],
);
$FILACT = $top->Dialog(
-title => 'File Selection',
-bitmap => 'info',
-text => 'This is a dummy file selection dialog box, which is used because there isn\'t a good file selection dialog built into Tk yet.',
);
$help = $top->Dialog(-title => 'Rolodex Help',-justify => 'left');
sub deleteAction {
&clearAction if $DELACT->Show eq 'OK';
}
$buttons_delete->configure(-command => \&deleteAction);
sub fileAction {
print STDERR "dummy file name\n" if $FILACT->Show eq 'OK';
}
#------------------------------------------
# Phase 3: Print contents of card
#------------------------------------------
sub addAction {
foreach $i (1..7) {
($f,$l,$e) = ("frame_${i}", "frame_${i}_l", "frame_${i}_e");
printf STDERR "%-12s %s\n", $names[$i], ${$e}->get;
}
}
$buttons_add->configure(-command => \&addAction);
#------------------------------------------
# Phase 4: Miscellaneous other actions
#------------------------------------------
sub clearAction {
foreach $i (1..7) {
($f,$l,$e) = ("frame_${i}", "frame_${i}_l", "frame_${i}_e");
${$e}->delete('0', 'end');
}
}
$buttons_clear->configure(-command => \&clearAction);
sub fillCard {
&clearAction;
my(@text) = ('', 'John Ousterhout', 'CS Division, Department of EECS',
'University of California', 'Berkeley, CA 94720',
'private', '510-642-0865', '510-642-5775');
foreach $i (1..7) {
($f,$l,$e) = ("frame_${i}", "frame_${i}_l", "frame_${i}_e");
${$e}->insert('0', $text[$i]);
}
}
$buttons_search->configure(-command => sub {&addAction; &fillCard});
#----------------------------------------------------
# Phase 5: Accelerators, mnemonics, command-line info
#----------------------------------------------------
$buttons_clear->configure(-text => 'Clear Ctrl+C');
$top->bind('<Control-c>' => \&clearAction);
$buttons_add->configure(-text => 'Add Ctrl+A');
$top->bind('<Control-a>' => \&addAction);
$buttons_search->configure(-text => 'Search Ctrl+S');
$top->bind('<Control-s>' => sub {&addAction; &fillCard});
$buttons_delete->configure(-text => 'Delete... Ctrl+D');
$top->bind('<Control-d>' => \&deleteAction);
$menu_file_m = $menu_file->cget(-menu);
$menu_file_m->entryconfigure(1, -accelerator => 'Ctrl+F');
$top->bind('<Control-f>' => \&fileAction);
$menu_file_m->entryconfigure(2, -accelerator => 'Ctrl+Q');
$top->bind('<Control-q>' => sub {exit});
# We do this rather than simply $frame_1_e->focus to eliminate the Perl
# "single use" warning message.
${"frame_1_e"}->focus;
#----------------------------------------------------
# Phase 6: help
#----------------------------------------------------
sub Help {
my($topic, $x, $y) = @_;
if ($topic eq '') {return;};
while (defined $helpCmds{$topic}) {
$topic = $helpCmds{$topic};
}
for $widget (keys %ref_to_name) {
$topic = $widget if $topic eq $ref_to_name{$widget};
}
if (defined $helpTopics{$topic}) {
$msg = $helpTopics{$topic};
} else {
$msg = 'Sorry, but no help is available for this topic';
}
$help->Subwidget('message')->configure(
-text => "Information on $topic:\n\n$msg");
$help->Show;
}
$top->bind('<Any-F1>' => sub {
my $w = shift;
my $e = $w->XEvent;
&Help($w->containing($e->X, $e->Y), $e->X, $e->Y);
});
$top->bind('<Any-Help>' => sub {
my $w = shift;
my $e = $w->XEvent;
&Help($w->containing($e->X, $e->Y), $e->X, $e->Y);
});
# Help text and commands follow:
$helpTopics{'menu_file'} = 'This is the "file" menu. It can be used to invoke some overall operations on the rolodex ' .
'applications, such as loading a file or exiting.';
$helpTopics{'frame_1_e'} = 'In this field of the rolodex entry you should type the person\'s name';
$helpTopics{'frame_2_e'} = 'In this field of the rolodex entry you should type the first line of the person\'s address';
$helpTopics{'frame_3_e'} = 'In this field of the rolodex entry you should type the second line of the person\'s address';
$helpTopics{'frame_4_e'} = 'In this field of the rolodex entry you should type the third line of the person\'s address';
$helpTopics{'frame_5_e'} = 'In this field of the rolodex entry you should type the person\'s home phone number, or ' .
'"private" if the person doesn\'t want his or her number publicized';
$helpTopics{'frame_6_e'} = 'In this field of the rolodex entry you should type the person\'s work phone number';
$helpTopics{'frame_7_e'} = 'In this field of the rolodex entry you should type the phone number for the person\'s FAX machine';
$helpCmds{'frame_1_l'} = 'frame_1_e';
$helpCmds{'frame_2_l'} = 'frame_2_e';
$helpCmds{'frame_3_l'} = 'frame_3_e';
$helpCmds{'frame_4_l'} = 'frame_4_e';
$helpCmds{'frame_5_l'} = 'frame_5_e';
$helpCmds{'frame_6_l'} = 'frame_6_e';
$helpCmds{'frame_7_l'} = 'frame_7_e';
$helpTopics{'context'} = 'Unfortunately, this application doesn\'t support context-sensitive help in the usual way, because ' .
'when this demo was written Tk didn\'t have a grab mechanism and this is needed for context-sensitive help. ' .
'Instead, you can achieve much the same effect by simply moving the mouse over the window you\'re curious about ' .
'and pressing the Help or F1 keys. You can do this anytime.';
$helpTopics{'help'} = 'This application provides only very crude help. Besides the entries in this menu, you can get help ' .
'on individual windows by moving the mouse cursor over the window and pressing the Help or F1 keys.';
$helpTopics{'window'} = 'This window is a dummy rolodex application created as part of Tom LaStrange\'s toolkit benchmark. ' .
'It doesn\'t really do anything useful except to demonstrate a few features of the Tk toolkit.';
$helpTopics{'keys'} = "The following accelerator keys are defined for this application (in addition to those already " .
"available for the entry windows):\n\nCtrl+A:\t\tAdd\nCtrl+C:\t\tClear\nCtrl+D:\t\tDelete\nCtrl+F:\t\tEnter file " .
"name\nCtrl+Q:\t\tExit application (quit)\nCtrl+S:\t\tSearch (dummy operation)";
$helpTopics{'version'} = 'This is version 1.0.';
# Entries in "Help" menu
$menu_help->command(-label => 'On Context...', -command => [\&Help, 'context'], -underline => 3);
$menu_help->command(-label => 'On Help...', -command => [\&Help, 'help'], -underline => 3);
$menu_help->command(-label => 'On Window...', -command => [\&Help, 'window'], -underline => 3);
$menu_help->command(-label => 'On Keys...', -command => [\&Help, 'keys'], -underline => 3);
$menu_help->command(-label => 'On Version...', -command => [\&Help, 'version'], -underline => 3);
MainLoop;
|
