New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
GUI.pm in vendors/lib/FCM1/Interactive/InputGetter – NEMO

source: vendors/lib/FCM1/Interactive/InputGetter/GUI.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing

File size: 7.7 KB
Line 
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# ------------------------------------------------------------------------------
19use strict;
20use warnings;
21
22package FCM1::Interactive::InputGetter::GUI;
23use base qw{FCM1::Interactive::InputGetter};
24
25use Tk;
26
27################################################################################
28# Returns the geometry string for the pop up message box
29sub get_geometry {
30    my ($self) = @_;
31    return $self->{geometry};
32}
33
34################################################################################
35# Invokes the getter
36sub 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
2031;
204__END__
205
206=head1 NAME
207
208FCM1::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
222This is a solid implementation of
223L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter>. It gets a user
224reply from a TK pop up message box.
225
226=head1 METHODS
227
228See L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter> for a list of
229inherited methods.
230
231=over 4
232
233=item new($args_ref)
234
235As in L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter>, but also
236accept a I<geometry> element for setting the geometry string of the pop up
237message box.
238
239=item get_geometry()
240
241Returns the geometry string for the pop up message box.
242
243=back
244
245=head1 TO DO
246
247Tidy up the logic of invoke(). Separate the logic for YN/A box and string input
248box, probably using a strategy pattern. Factor out the logic for the display
249and the return value.
250
251=head1 SEE ALSO
252
253L<FCM1::Interactive|FCM1::Interactive>,
254L<FCM1::Interactive::InputGetter|FCM1::Interactive::InputGetter>,
255L<FCM1::Interactive::InputGetter::CLI|FCM1::Interactive::InputGetter::CLI>
256
257=head1 COPYRIGHT
258
259E<169> Crown copyright Met Office. All rights reserved.
260
261=cut
Note: See TracBrowser for help on using the repository browser.