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