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/fcm/current/lib/Fcm/Interactive/InputGetter – NEMO

source: vendors/fcm/current/lib/Fcm/Interactive/InputGetter/GUI.pm @ 1980

Last change on this file since 1980 was 1980, checked in by flavoni, 14 years ago

importing fcm vendor

File size: 7.2 KB
Line 
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# ------------------------------------------------------------------------------
6use strict;
7use warnings;
8
9package Fcm::Interactive::InputGetter::GUI;
10use base qw{Fcm::Interactive::InputGetter};
11
12use Tk;
13
14################################################################################
15# Returns the geometry string for the pop up message box
16sub get_geometry {
17    my ($self) = @_;
18    return $self->{geometry};
19}
20
21################################################################################
22# Invokes the getter
23sub 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
1901;
191__END__
192
193=head1 NAME
194
195Fcm::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
209This is a solid implementation of
210L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>. It gets a user
211reply from a TK pop up message box.
212
213=head1 METHODS
214
215See L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter> for a list of
216inherited methods.
217
218=over 4
219
220=item new($args_ref)
221
222As in L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, but also
223accept a I<geometry> element for setting the geometry string of the pop up
224message box.
225
226=item get_geometry()
227
228Returns the geometry string for the pop up message box.
229
230=back
231
232=head1 TO DO
233
234Tidy up the logic of invoke(). Separate the logic for YN/A box and string input
235box, probably using a strategy pattern. Factor out the logic for the display
236and the return value.
237
238=head1 SEE ALSO
239
240L<Fcm::Interactive|Fcm::Interactive>,
241L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>,
242L<Fcm::Interactive::InputGetter::CLI|Fcm::Interactive::InputGetter::CLI>
243
244=head1 COPYRIGHT
245
246E<169> Crown copyright Met Office. All rights reserved.
247
248=cut
Note: See TracBrowser for help on using the repository browser.