[10669] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # (C) British Crown Copyright 2006-17 Met Office. |
---|
| 3 | # |
---|
| 4 | # This file is part of FCM, tools for managing and building source code. |
---|
| 5 | # |
---|
| 6 | # FCM is free software: you can redistribute it and/or modify |
---|
| 7 | # it under the terms of the GNU General Public License as published by |
---|
| 8 | # the Free Software Foundation, either version 3 of the License, or |
---|
| 9 | # (at your option) any later version. |
---|
| 10 | # |
---|
| 11 | # FCM is distributed in the hope that it will be useful, |
---|
| 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
| 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
| 14 | # GNU General Public License for more details. |
---|
| 15 | # |
---|
| 16 | # You should have received a copy of the GNU General Public License |
---|
| 17 | # along with FCM. If not, see <http://www.gnu.org/licenses/>. |
---|
| 18 | # ------------------------------------------------------------------------------ |
---|
| 19 | use strict; |
---|
| 20 | use warnings; |
---|
| 21 | |
---|
| 22 | package FCM1::Interactive::InputGetter::GUI; |
---|
| 23 | use base qw{FCM1::Interactive::InputGetter}; |
---|
| 24 | |
---|
| 25 | use Tk; |
---|
| 26 | |
---|
| 27 | ################################################################################ |
---|
| 28 | # Returns the geometry string for the pop up message box |
---|
| 29 | sub get_geometry { |
---|
| 30 | my ($self) = @_; |
---|
| 31 | return $self->{geometry}; |
---|
| 32 | } |
---|
| 33 | |
---|
| 34 | ################################################################################ |
---|
| 35 | # Invokes the getter |
---|
| 36 | sub invoke { |
---|
| 37 | my ($self) = @_; |
---|
| 38 | my $answer; |
---|
| 39 | local $| = 1; |
---|
| 40 | |
---|
| 41 | # Create a main window |
---|
| 42 | my $mw = MainWindow->new(); |
---|
| 43 | $mw->title($self->get_title()); |
---|
| 44 | |
---|
| 45 | # Define the default which applies if the dialog box is just closed or |
---|
| 46 | # the user selects 'cancel' |
---|
| 47 | $answer = $self->get_default() ? $self->get_default() : q{}; |
---|
| 48 | |
---|
| 49 | if (defined($self->get_type()) && $self->get_type() =~ qr{\A yn}ixms) { |
---|
| 50 | # Create a yes-no(-all) dialog box |
---|
| 51 | |
---|
| 52 | # If TYPE is YNA then add a third button: 'all' |
---|
| 53 | my $buttons = $self->get_type() =~ qr{a \z}ixms ? 3 : 2; |
---|
| 54 | |
---|
| 55 | # Message of the dialog box |
---|
| 56 | $mw->Label('-text' => $self->get_message())->grid( |
---|
| 57 | '-row' => 0, |
---|
| 58 | '-column' => 0, |
---|
| 59 | '-columnspan' => $buttons, |
---|
| 60 | '-padx' => 10, |
---|
| 61 | '-pady' => 10, |
---|
| 62 | ); |
---|
| 63 | |
---|
| 64 | # The "yes" button |
---|
| 65 | my $y_b = $mw->Button( |
---|
| 66 | '-text' => 'Yes', |
---|
| 67 | '-underline' => 0, |
---|
| 68 | '-command' => sub {$answer = 'y'; $mw->destroy()}, |
---|
| 69 | ) |
---|
| 70 | ->grid('-row' => 1, '-column' => 0, '-padx' => 5, '-pady' => 5); |
---|
| 71 | |
---|
| 72 | # The "no" button |
---|
| 73 | my $n_b = $mw->Button ( |
---|
| 74 | '-text' => 'No', |
---|
| 75 | '-underline' => 0, |
---|
| 76 | '-command' => sub {$answer = 'n'; $mw->destroy()}, |
---|
| 77 | ) |
---|
| 78 | ->grid('-row' => 1, '-column' => 1, '-padx' => 5, '-pady' => 5); |
---|
| 79 | |
---|
| 80 | # The "all" button |
---|
| 81 | my $a_b; |
---|
| 82 | if ($buttons == 3) { |
---|
| 83 | $a_b = $mw->Button( |
---|
| 84 | '-text' => 'All', |
---|
| 85 | '-underline' => 0, |
---|
| 86 | '-command' => sub {$answer = 'a'; $mw->destroy()}, |
---|
| 87 | ) |
---|
| 88 | ->grid('-row' => 1, '-column' => 2, '-padx' => 5, '-pady' => 5); |
---|
| 89 | } |
---|
| 90 | |
---|
| 91 | # Keyboard binding |
---|
| 92 | if ($buttons == 3) { |
---|
| 93 | $mw->bind('<Key>' => sub { |
---|
| 94 | my $button |
---|
| 95 | = $Tk::event->K() eq 'Y' || $Tk::event->K() eq 'y' ? $y_b |
---|
| 96 | : $Tk::event->K() eq 'N' || $Tk::event->K() eq 'n' ? $n_b |
---|
| 97 | : $Tk::event->K() eq 'A' || $Tk::event->K() eq 'a' ? $a_b |
---|
| 98 | : undef |
---|
| 99 | ; |
---|
| 100 | if (defined($button)) { |
---|
| 101 | $button->invoke(); |
---|
| 102 | } |
---|
| 103 | }); |
---|
| 104 | } |
---|
| 105 | else { |
---|
| 106 | $mw->bind('<Key>' => sub { |
---|
| 107 | my $button |
---|
| 108 | = $Tk::event->K() eq 'Y' || $Tk::event->K() eq 'y' ? $y_b |
---|
| 109 | : $Tk::event->K() eq 'N' || $Tk::event->K() eq 'n' ? $n_b |
---|
| 110 | : undef |
---|
| 111 | ; |
---|
| 112 | if (defined($button)) { |
---|
| 113 | $button->invoke(); |
---|
| 114 | } |
---|
| 115 | }); |
---|
| 116 | } |
---|
| 117 | |
---|
| 118 | # Handle the situation when the user attempts to quit the window |
---|
| 119 | $mw->protocol('WM_DELETE_WINDOW', sub { |
---|
| 120 | if (self->get_default()) { |
---|
| 121 | $answer = $self->get_default(); |
---|
| 122 | } |
---|
| 123 | $mw->destroy(); |
---|
| 124 | }); |
---|
| 125 | } |
---|
| 126 | else { |
---|
| 127 | # Create a dialog box to obtain an input string |
---|
| 128 | # Message of the dialog box |
---|
| 129 | $mw->Label('-text' => $self->get_message())->grid( |
---|
| 130 | '-row' => 0, |
---|
| 131 | '-column' => 0, |
---|
| 132 | '-padx' => 5, |
---|
| 133 | '-pady' => 5, |
---|
| 134 | ); |
---|
| 135 | |
---|
| 136 | # Entry box for the user to type in the input string |
---|
| 137 | my $entry = $answer; |
---|
| 138 | my $input_e = $mw->Entry( |
---|
| 139 | '-textvariable' => \$entry, |
---|
| 140 | '-width' => 40, |
---|
| 141 | ) |
---|
| 142 | ->grid( |
---|
| 143 | '-row' => 0, |
---|
| 144 | '-column' => 1, |
---|
| 145 | '-sticky' => 'ew', |
---|
| 146 | '-padx' => 5, |
---|
| 147 | '-pady' => 5, |
---|
| 148 | ); |
---|
| 149 | |
---|
| 150 | my $b_f = $mw->Frame->grid( |
---|
| 151 | '-row' => 1, |
---|
| 152 | '-column' => 0, |
---|
| 153 | '-columnspan' => 2, |
---|
| 154 | '-sticky' => 'e', |
---|
| 155 | ); |
---|
| 156 | |
---|
| 157 | # An OK button to accept the input string |
---|
| 158 | my $ok_b = $b_f->Button ( |
---|
| 159 | '-text' => 'OK', |
---|
| 160 | '-command' => sub {$answer = $entry; $mw->destroy()}, |
---|
| 161 | ) |
---|
| 162 | ->grid('-row' => 0, '-column' => 0, '-padx' => 5, '-pady' => 5); |
---|
| 163 | |
---|
| 164 | # A Cancel button to reject the input string |
---|
| 165 | my $cancel_b = $b_f->Button( |
---|
| 166 | '-text' => 'Cancel', |
---|
| 167 | '-command' => sub {$answer = undef; $mw->destroy()}, |
---|
| 168 | ) |
---|
| 169 | ->grid('-row' => 0, '-column' => 1, '-padx' => 5, '-pady' => 5); |
---|
| 170 | |
---|
| 171 | # Keyboard binding |
---|
| 172 | $mw->bind ('<Key>' => sub { |
---|
| 173 | if ($Tk::event->K eq 'Return' or $Tk::event->K eq 'KP_Enter') { |
---|
| 174 | $ok_b->invoke(); |
---|
| 175 | } |
---|
| 176 | elsif ($Tk::event->K eq 'Escape') { |
---|
| 177 | $cancel_b->invoke(); |
---|
| 178 | } |
---|
| 179 | }); |
---|
| 180 | |
---|
| 181 | # Allow the entry box to expand |
---|
| 182 | $mw->gridColumnconfigure(1, '-weight' => 1); |
---|
| 183 | |
---|
| 184 | # Set initial focus on the entry box |
---|
| 185 | $input_e->focus(); |
---|
| 186 | $input_e->icursor('end'); |
---|
| 187 | } |
---|
| 188 | |
---|
| 189 | $mw->geometry($self->get_geometry()); |
---|
| 190 | |
---|
| 191 | # Switch on "always on top" property for $mw |
---|
| 192 | $mw->property( |
---|
| 193 | qw/set _NET_WM_STATE ATOM/, |
---|
| 194 | 32, |
---|
| 195 | ['_NET_WM_STATE_STAYS_ON_TOP'], |
---|
| 196 | ($mw->toplevel()->wrapper())[0], |
---|
| 197 | ); |
---|
| 198 | |
---|
| 199 | MainLoop(); |
---|
| 200 | return $answer; |
---|
| 201 | } |
---|
| 202 | |
---|
| 203 | 1; |
---|
| 204 | __END__ |
---|
| 205 | |
---|
| 206 | =head1 NAME |
---|
| 207 | |
---|
| 208 | FCM1::Interactive::InputGetter::GUI |
---|
| 209 | |
---|
| 210 | =head1 SYNOPSIS |
---|
| 211 | |
---|
| 212 | use FCM1::Interactive; |
---|
| 213 | $answer = FCM1::Interactive::get_input( |
---|
| 214 | title => 'My title', |
---|
| 215 | message => 'Would you like to ...?', |
---|
| 216 | type => 'yn', |
---|
| 217 | default => 'n', |
---|
| 218 | ); |
---|
| 219 | |
---|
| 220 | =head1 DESCRIPTION |
---|
| 221 | |
---|
| 222 | This is a solid implementation of |
---|
| 223 | L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter>. It gets a user |
---|
| 224 | reply from a TK pop up message box. |
---|
| 225 | |
---|
| 226 | =head1 METHODS |
---|
| 227 | |
---|
| 228 | See L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter> for a list of |
---|
| 229 | inherited methods. |
---|
| 230 | |
---|
| 231 | =over 4 |
---|
| 232 | |
---|
| 233 | =item new($args_ref) |
---|
| 234 | |
---|
| 235 | As in L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter>, but also |
---|
| 236 | accept a I<geometry> element for setting the geometry string of the pop up |
---|
| 237 | message box. |
---|
| 238 | |
---|
| 239 | =item get_geometry() |
---|
| 240 | |
---|
| 241 | Returns the geometry string for the pop up message box. |
---|
| 242 | |
---|
| 243 | =back |
---|
| 244 | |
---|
| 245 | =head1 TO DO |
---|
| 246 | |
---|
| 247 | Tidy up the logic of invoke(). Separate the logic for YN/A box and string input |
---|
| 248 | box, probably using a strategy pattern. Factor out the logic for the display |
---|
| 249 | and the return value. |
---|
| 250 | |
---|
| 251 | =head1 SEE ALSO |
---|
| 252 | |
---|
| 253 | L<FCM1::Interactive|FCM1::Interactive>, |
---|
| 254 | L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter>, |
---|
| 255 | L<FCM1::Interactive::InputGetter::CLI|FCM1::Interactive::InputGetter::CLI> |
---|
| 256 | |
---|
| 257 | =head1 COPYRIGHT |
---|
| 258 | |
---|
| 259 | E<169> Crown copyright Met Office. All rights reserved. |
---|
| 260 | |
---|
| 261 | =cut |
---|