1 | #------------------------------------------------------------------------------- |
---|
2 | # Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
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 | #------------------------------------------------------------------------------- |
---|
23 | package FCM::System::CM::Prompt; |
---|
24 | use base qw{FCM::Class::CODE}; |
---|
25 | |
---|
26 | use FCM::Context::Event; |
---|
27 | |
---|
28 | our $TYPE_YN = 'TYPE_YN'; |
---|
29 | |
---|
30 | # Format string table |
---|
31 | my %S = ( |
---|
32 | 'BRANCH_CREATE' => 'Create the branch?', |
---|
33 | 'OVERWRITE' => '%s: file exists, overwrite?', |
---|
34 | 'PROJECT_CREATE' => 'Create the project?', |
---|
35 | 'RESOLVE' => 'Run "svn resolve --accept working %s"?', |
---|
36 | 'TC' => "Locally: %s.\n" |
---|
37 | . "Externally: %s.\n" |
---|
38 | . "Answer (y) to %s.\n" |
---|
39 | . "Answer (n) to %s.\n" |
---|
40 | . '%s' |
---|
41 | . 'Keep the local version?', |
---|
42 | 'TC_ACTION' => 'accept the %s %s', |
---|
43 | 'TC_ACTION_ADD' => 'keep the %s file filename', |
---|
44 | 'TC_ACTION_EDIT' => 'keep the file', |
---|
45 | 'TC_FROM_LOC' => 'local', |
---|
46 | 'TC_FROM_INC' => 'external', |
---|
47 | 'TC_MERGE' => "You can then merge in changes.\n", |
---|
48 | 'TC_ST_ADD' => 'added', |
---|
49 | 'TC_ST_DELETE' => 'deleted', |
---|
50 | 'TC_ST_EDIT' => 'edited', |
---|
51 | 'TC_ST_REPLACE' => 'replaced', |
---|
52 | 'TC_ST_RENAME' => 'renamed to %s', |
---|
53 | ); |
---|
54 | |
---|
55 | # Configuration for questions |
---|
56 | # KEY => {'format' => $|&, 'type' => $} |
---|
57 | my %Q_CONF = ( |
---|
58 | # Simple question prompts |
---|
59 | ( map {($_ => {'format' => $S{$_}, 'type' => q{}})} |
---|
60 | qw{BRANCH_CREATE OVERWRITE PROJECT_CREATE RESOLVE} |
---|
61 | ), |
---|
62 | # Tree conflicts prompts: TC_LxIy, for local x, incoming y |
---|
63 | # where x and y correspond to: |
---|
64 | # A => add, |
---|
65 | # D => delete, |
---|
66 | # E => edit, |
---|
67 | # M => missing, |
---|
68 | # P => replace, |
---|
69 | # R => rename |
---|
70 | ( map {('TC_' . $_ => {'format' => \&_q_tree_conflict, 'type' => $TYPE_YN})} |
---|
71 | qw(LAIA LDID LDIE LDIR LEID LEIP LEIR LRID LRIE LRIR) |
---|
72 | ), |
---|
73 | ); |
---|
74 | |
---|
75 | __PACKAGE__->class( |
---|
76 | {gui => '$', util => '&'}, |
---|
77 | {init => \&_init, action_of => {question => \&_q}}, |
---|
78 | ); |
---|
79 | |
---|
80 | sub _init { |
---|
81 | my $attrib_ref = shift(); |
---|
82 | my $class = $attrib_ref->{gui} |
---|
83 | ? 'FCM::System::CM::Prompt::Zenity' : 'FCM::System::CM::Prompt::Simple'; |
---|
84 | $attrib_ref->{impl} = $class->new({util => $attrib_ref->{util}}); |
---|
85 | } |
---|
86 | |
---|
87 | sub _q { |
---|
88 | my ($attrib_ref, $key, @args) = @_; |
---|
89 | my $format = $Q_CONF{$key}{'format'}; |
---|
90 | my $prompt = ref($format) ? $format->(@args) : sprintf($format, @args); |
---|
91 | $attrib_ref->{'impl'}->question($Q_CONF{$key}{'type'}, $prompt); |
---|
92 | } |
---|
93 | |
---|
94 | # Tree conflict prompt. |
---|
95 | # $tree_key is the FCM::System::CM::TreeConflictKey for the conflict. |
---|
96 | # $rename_loc is the new local name for the conflict file, if any. |
---|
97 | # $rename_inc is the new incoming name for the conflict file, if any. |
---|
98 | sub _q_tree_conflict { |
---|
99 | my ($tree_key, $rename_loc, $rename_inc) = @_; |
---|
100 | my %opt_of = ( |
---|
101 | 'loc' => {'key' => $tree_key->get_local() , 'rename' => $rename_loc}, |
---|
102 | 'inc' => {'key' => $tree_key->get_incoming(), 'rename' => $rename_inc}, |
---|
103 | ); |
---|
104 | sprintf($S{'TC'}, ( |
---|
105 | ( map { |
---|
106 | my $opt = $_; |
---|
107 | my $message = $S{'TC_ST_' . uc($opt->{'key'})}; |
---|
108 | if ($opt->{'key'} eq 'rename') { |
---|
109 | $message = sprintf($message, $opt->{'rename'}); |
---|
110 | } |
---|
111 | $message; |
---|
112 | } |
---|
113 | @opt_of{'loc', 'inc'} |
---|
114 | ), |
---|
115 | ( map { |
---|
116 | my $location_key = $_; |
---|
117 | my $from = $S{'TC_FROM_' . uc($location_key)}; |
---|
118 | my $key = $opt_of{$location_key}->{'key'}; |
---|
119 | $key eq 'add' ? sprintf($S{'TC_ACTION_ADD'}, $from) |
---|
120 | : $key eq 'edit' ? $S{'TC_ACTION_EDIT'} |
---|
121 | : sprintf($S{'TC_ACTION'}, $from, $key) |
---|
122 | ; |
---|
123 | } |
---|
124 | ('loc', 'inc') |
---|
125 | ), |
---|
126 | ( ( (grep {$opt_of{'loc'}{'key'} eq $_} qw{rename edit}) |
---|
127 | && (grep {$opt_of{'inc'}{'key'} eq $_} qw{rename edit}) |
---|
128 | ) |
---|
129 | ? $S{'TC_MERGE'} : q{} |
---|
130 | ), |
---|
131 | )); |
---|
132 | } |
---|
133 | |
---|
134 | #------------------------------------------------------------------------------- |
---|
135 | package FCM::System::CM::Prompt::Simple; |
---|
136 | use base qw{FCM::Class::CODE}; |
---|
137 | |
---|
138 | use FCM::Context::Event; |
---|
139 | |
---|
140 | our %SETTING_OF = ( |
---|
141 | q{} => {'choices' => [qw{y n}], 'default' => 'n', 'positive' => 'y'}, |
---|
142 | 'TYPE_YN' => {'choices' => [qw{y n}], 'default' => 'n', 'positive' => 'y'}, |
---|
143 | ); |
---|
144 | |
---|
145 | __PACKAGE__->class({util => '&'}, {action_of => {question => \&_question}}); |
---|
146 | |
---|
147 | sub _question { |
---|
148 | my ($attrib_ref, $type, $question) = @_; |
---|
149 | my %setting = %{$SETTING_OF{$type}}; |
---|
150 | _prompt($attrib_ref, $question, $setting{'choices'}, $setting{'default'}) |
---|
151 | eq $setting{'positive'}; |
---|
152 | } |
---|
153 | |
---|
154 | sub _prompt { |
---|
155 | my ($attrib_ref, $question, $choices_ref, $default) = @_; |
---|
156 | my ($tail, @heads) = reverse(@{$choices_ref}); |
---|
157 | my $prompt |
---|
158 | = $question . "\n" |
---|
159 | . sprintf('Enter "%s" or "%s"', join(q{, }, reverse(@heads)), $tail) |
---|
160 | . sprintf(' (or just press <return> for "%s") ', $default); |
---|
161 | my $answer; |
---|
162 | while (!defined($answer)) { |
---|
163 | $attrib_ref->{util}->event(FCM::Context::Event->OUT, $prompt); |
---|
164 | $answer = readline(STDIN); |
---|
165 | chomp($answer); |
---|
166 | if (!$answer) { |
---|
167 | $answer = $default; |
---|
168 | } |
---|
169 | if (!grep {$_ eq $answer} @{$choices_ref}) { |
---|
170 | $answer = undef; |
---|
171 | } |
---|
172 | } |
---|
173 | return $answer; |
---|
174 | } |
---|
175 | |
---|
176 | #------------------------------------------------------------------------------- |
---|
177 | package FCM::System::CM::Prompt::Zenity; |
---|
178 | use base qw{FCM::Class::CODE}; |
---|
179 | |
---|
180 | our %OPTIONS_OF = ( |
---|
181 | q{} => [], |
---|
182 | 'TYPE_YN' => ['--ok-label=_Yes', '--cancel-label=_No'], |
---|
183 | ); |
---|
184 | |
---|
185 | __PACKAGE__->class({util => '&'}, {action_of => {question => \&_question}}); |
---|
186 | |
---|
187 | sub _question { |
---|
188 | my ($attrib_ref, $type, $question) = @_; |
---|
189 | _zenity($attrib_ref, qw{--question --text}, $question, @{$OPTIONS_OF{$type}}); |
---|
190 | } |
---|
191 | |
---|
192 | sub _zenity { |
---|
193 | my ($attrib_ref, @args) = @_; |
---|
194 | my @command = ('zenity', @args); |
---|
195 | my %value_of = %{$attrib_ref->{util}->shell_simple(\@command)}; |
---|
196 | !$value_of{rc}; |
---|
197 | } |
---|
198 | |
---|
199 | 1; |
---|
200 | __END__ |
---|
201 | |
---|
202 | =head1 NAME |
---|
203 | |
---|
204 | FCM::System::CM::Prompt |
---|
205 | |
---|
206 | =head1 SYNOPSIS |
---|
207 | |
---|
208 | use FCM::System::CM::Prompt; |
---|
209 | my $prompt = FCM::System::CM::Prompt->new(\%attrib); |
---|
210 | if ($prompt->question($key, @args)) { |
---|
211 | # do something |
---|
212 | } |
---|
213 | |
---|
214 | =head1 DESCRIPTION |
---|
215 | |
---|
216 | Helper module for prompts in the FCM code management sub-system. |
---|
217 | See L<FCM::System::CM|FCM::System::CM> for detail. |
---|
218 | |
---|
219 | =head1 COPYRIGHT |
---|
220 | |
---|
221 | Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
222 | |
---|
223 | =cut |
---|