1# A few GUI routines for asking the user questions using the Tk library.
2
3package XMLTV::Ask::Tk;
4use strict;
5
6# Use Log::TraceMessages if installed.
7BEGIN {
8    eval { require Log::TraceMessages };
9    if ($@) {
10        *t = sub {};
11        *d = sub { '' };
12    }
13    else {
14        *t = \&Log::TraceMessages::t;
15        *d = \&Log::TraceMessages::d;
16    }
17}
18
19use Tk;
20
21my $main_window;
22my $top_frame;
23my $middle_frame;
24my $bottom_frame;
25my $mid_bottom_frame;
26
27# Ask a question with a free text answer.
28# Parameters:
29#   current module
30#   question text
31#   what character to show instead of the one typed
32# Returns the text entered by the user.
33sub ask( $$$ ) {
34    shift;
35    my $question = shift;
36    my $show = shift;
37
38    my $textbox;
39
40    $main_window = MainWindow->new;
41
42    $main_window->title("Question");
43    $main_window->minsize(qw(400 250));
44    $main_window->geometry('+250+150');
45
46    $top_frame    = $main_window->Frame()->pack;
47    $middle_frame = $main_window->Frame()->pack;
48    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
49
50    $top_frame->Label(-height => 2)->pack;
51
52    $top_frame->Label(-text => $question)->pack;
53
54    my $ans;
55
56    $bottom_frame->Button(-text    => "OK",
57                          -command => sub {$ans = $textbox->get(); $main_window->destroy;},
58                          -width    => 10
59                         )->pack(-padx => 2, -pady => 4);
60
61    if (defined $show) {
62        $textbox = $middle_frame->Entry(-show => $show)->pack();
63    }
64    else {
65        $textbox = $middle_frame->Entry()->pack();
66    }
67    MainLoop();
68
69    return $ans;
70}
71
72# Ask a question with a password answer.
73# Parameters:
74#   current module
75#   question text
76# Returns the text entered by the user.
77sub ask_password( $$ ) { ask($_[0], $_[1], "*") }
78
79
80# Ask a question where the answer is one of a set of alternatives.
81#
82# Parameters:
83#   current module
84#   question text
85#   default choice
86#   Remaining arguments are the choices available.
87#
88# Returns one of the choices, or undef if input could not be read.
89#
90sub ask_choice( $$$@ ) {
91    shift;
92    my $question = shift; die if not defined $question;
93    my $default = shift; die if not defined $default;
94    my @options = @_; die if not @options;
95    t "asking question $question, default $default";
96    warn "default $default not in options"
97        if not grep { $_ eq $default } @options;
98    return _ask_choices( $question, $default, 0, @options );
99}
100
101# Ask a yes/no question.
102#
103# Parameters:
104#   current module
105#   question text
106#   default (true or false)
107#
108# Returns true or false, or undef if input could not be read.
109#
110sub ask_boolean( $$$ ) {
111    shift;
112    my ($text, $default) = @_;
113    t "asking question $text, default $default";
114
115    $main_window = MainWindow->new;
116
117    $main_window->title('Question');
118    $main_window->minsize(qw(400 250));
119    $main_window->geometry('+250+150');
120
121    $top_frame    = $main_window->Frame()->pack;
122    $middle_frame = $main_window->Frame()->pack;
123    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
124
125    $top_frame->Label(-height => 2)->pack;
126    $top_frame->Label(-text => $text)->pack;
127
128    my $ans = 0;
129
130    $bottom_frame->Button(-text    => "Yes",
131                          -command => sub { $ans = 1; $main_window->destroy; },
132                          -width => 10,
133                         )->pack(-side => 'left', -padx => 2, -pady => 4);
134
135    $bottom_frame->Button(-text    => "No",
136                          -command => sub { $ans = 0; $main_window->destroy; },
137                          -width => 10
138                         )->pack(-side => 'left', -padx => 2, -pady => 4);
139
140    MainLoop();
141
142    return $ans;
143}
144
145# Ask yes/no questions with option 'default to all'.
146#
147# Parameters:
148#   current module
149#   default (true or false),
150#   question texts (one per question).
151#
152# Returns: lots of booleans, one for each question.  If input cannot
153# be read, then a partial list is returned.
154#
155sub ask_many_boolean( $$@ ) {
156    shift;
157    my $default=shift;
158    my @options = @_;
159    return _ask_choices('', $default, 1, @options);
160}
161
162# A helper routine used to create the listbox for both
163# ask_choice and ask_many_boolean
164sub _ask_choices( $$$@ ) {
165    my $question=shift;
166    my $default=shift;
167    my $allowedMany=shift;
168    my @options = @_;
169
170    return if not @options;
171
172    my $select_all_button;
173    my $select_none_button;
174
175    my $listbox;
176    my $i;
177
178    $main_window = MainWindow->new;
179
180    $main_window->title('Question');
181    $main_window->minsize(qw( 400 250 ));
182    $main_window->geometry('+250+150');
183
184    $top_frame    = $main_window->Frame()->pack;
185    $middle_frame = $main_window->Frame()->pack(-fill => 'both');
186
187    $top_frame->Label(-height => 2)->pack;
188
189    $top_frame->Label(-text => $question)->pack;
190
191    $listbox = $middle_frame->ScrlListbox();
192
193    $listbox->insert(0, @options);
194
195    if ($allowedMany) {
196        $listbox->configure( -selectmode => 'multiple' );
197
198        if ($default) {
199            $listbox->selectionSet( 0, 'end' );
200        }
201
202        $mid_bottom_frame = $main_window->Frame()->pack();
203
204    $select_all_button = $mid_bottom_frame->Button
205        (-text => 'Select All',
206         -command => sub { $listbox->selectionSet(0, 1000) },
207         -width => 10,
208        )->pack(-side => 'left');
209
210    $select_none_button = $mid_bottom_frame->Button
211        (-text => 'Select None',
212         -command => sub { $listbox->selectionClear(0, 1000) },
213         -width => 10,
214        )-> pack(-side => 'right');
215    }
216    else {
217        $listbox->configure(-selectmode => 'single');
218        $listbox->selectionSet(_index_array($default, @options));
219    }
220
221    $listbox->pack(-fill => 'x', -padx => '5', -pady => '2');
222
223    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
224
225    my @cursel;
226
227    $bottom_frame->Button(-text    => 'OK',
228                          -command => sub { @cursel = $listbox->curselection; $main_window->destroy; },
229                          -width    => 10,
230                         )->pack(-padx => 2, -pady => 4);
231
232    MainLoop();
233
234    if ($allowedMany) {
235        my @choices;
236        my @choice_numbers = @cursel;
237
238        $i=0;
239        foreach (@options) {
240            push @choices, 0;
241            foreach( @choice_numbers ) {
242                if ($options[$_] eq $options[$i]) {
243                    $choices[$i] = 1;
244                }
245            }
246            $i++;
247        }
248
249        return @choices;
250    }
251    else {
252        my $ans = $options[$cursel[0]];
253        return $ans;
254    }
255}
256
257# Give some information to the user
258# Parameters:
259#   current module
260#   text to show to the user
261sub say( $$ ) {
262    shift;
263    my $question = shift;
264
265    $main_window = MainWindow->new;
266
267    $main_window->title("Information");
268    $main_window->minsize(qw(400 250));
269    $main_window->geometry('+250+150');
270
271    $top_frame    = $main_window->Frame()->pack;
272    $middle_frame = $main_window->Frame()->pack;
273    $bottom_frame = $main_window->Frame()->pack(-side => 'bottom');
274
275    $top_frame->Label(-height => 2)->pack;
276    $top_frame->Label(-text => $question)->pack;
277
278    $bottom_frame->Button(-text    => "OK",
279                          -command => sub { $main_window->destroy; },
280                          -width    => 10,
281                         )->pack(-padx => 2, -pady => 4);
282
283    MainLoop();
284}
285
286# A hekper routine that returns the index in an array
287# of the supplied argument
288# Parameters:
289#     the item to find
290#     the array to find it in
291# Returns the index of the item in the array, or -1 if not found
292sub _index_array($@)
293{
294    my $s=shift;
295    my @array = @_;
296
297    for (my $i = 0; $i < $#array; $i++) {
298        return $i if $array[$i] eq $s;
299    }
300
301    return -1;
302}
303
3041;
305