File Coverage

blib/lib/Config/Model/TermUI.pm
Criterion Covered Total %
statement 52 79 65.8
branch 6 24 25.0
condition 2 11 18.1
subroutine 12 14 85.7
pod 1 3 33.3
total 73 131 55.7


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model
3             #
4             # This software is Copyright (c) 2005-2022 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10              
11             use Carp;
12 1     1   12798 use utf8; # so literals and identifiers can be in UTF-8
  1         3  
  1         49  
13 1     1   6 use v5.12; # or later to get "unicode_strings" feature
  1         2  
  1         5  
14 1     1   21 use strict;
  1         4  
15 1     1   8 use warnings;
  1         3  
  1         15  
16 1     1   4 use open qw(:std :utf8); # undeclared streams in UTF-8
  1         2  
  1         34  
17 1     1   370 use Encode qw(decode_utf8);
  1         991  
  1         7  
18 1     1   124  
  1         2  
  1         41  
19             use Term::ReadLine;
20 1     1   6  
  1         3  
  1         31  
21             use base qw/Config::Model::SimpleUI/;
22 1     1   5  
  1         2  
  1         395  
23             my $completion_sub = sub {
24             my ( $self, $text, $line, $start ) = @_;
25              
26             my @choice = $self->{current_node}->get_element_name;
27             my @ret = grep { /^$text/ } @choice ;
28             return @ret;
29             };
30              
31             my $leaf_completion_sub = sub {
32             my ( $self, $text, $line, $start ) = @_;
33              
34             my @choice = $self->{current_node}->get_element_name( cargo_type => 'leaf' );
35             my @ret = grep { /^$text/ } @choice ;
36             return @ret;
37             };
38              
39             my $fix_completion_sub = sub {
40             my ( $self, $text, $line, $start ) = @_;
41              
42             my @choice = $self->{current_node}->get_element_name;
43             push @choice, '!';
44             my @ret = grep { /^$text/ } @choice ;
45             return @ret;
46             };
47              
48             my $ll_completion_sub = sub {
49             my ( $self, $text, $line, $start ) = @_;
50              
51             my @choice = $self->{current_node}->get_element_name;
52             push @choice, '-nz';
53             my @ret = grep { /^$text/ } @choice ;
54             return @ret;
55             };
56              
57             # BUG: autocompletion does not really work on a hash element with an index
58             # containing white space (i.e. something like std_id:"abc def",
59              
60             my $cd_completion_sub = sub {
61             my ( $self, $text, $line, $start ) = @_;
62              
63             # we know that text begins with 'cd '
64             my $cmd = $line;
65             $cmd =~ s/cd\s+//;
66              
67             # convert usual cd_ism ( '..' '/foo') to grab syntax ( '-' '! foo')
68             #$text =~ s(^/) (! );
69             $cmd =~ s(^\.\.$)(-)g;
70             #$text =~ s(/) ( )g;
71              
72             my $new_item;
73             while ( not defined $new_item ) {
74              
75             # grab in tolerant mode
76             #print "Grabbing $cmd\n";
77             eval {
78             $new_item = $self->{current_node}->grab( step => $cmd, type => 'node', mode => 'strict', autoadd => 0 );
79             };
80             chop $cmd;
81             }
82              
83             #print "Grab got ",$new_item->location,"\n";
84              
85             my @choice = length($line) > 3 ? () : ( '!', '-' );
86             my $new_type = $new_item->get_type;
87              
88             my @cargo = $new_item->get_element_name( cargo_type => 'node' );
89             foreach my $elt_name (@cargo) {
90             if ( $new_item->element_type($elt_name) =~ /hash|list/ ) {
91             push @choice, "$elt_name:";
92             foreach my $idx ( $new_item->fetch_element($elt_name)->fetch_all_indexes ) {
93             # my ($idx) = ($raw_idx =~ /([^\n]{1,40})/ );
94             # $idx .= '...' unless $raw_idx eq $idx ;
95             push @choice, "$elt_name:" . ($idx =~ /[^\w._-]/ ? qq("$idx") : $idx );
96             }
97             }
98             else {
99             push @choice, $elt_name;
100             }
101             }
102              
103             # filter possible choices according to input
104             my @ret = grep { /^$text/ } @choice ;
105              
106             return @ret;
107             };
108              
109             my $path_completion_sub = sub {
110             my ( $self, $text, $line, $start, $node_only ) = @_;
111              
112             # we know that text begins with a command
113             my $cmd = $line;
114             $cmd =~ s/^\w+\s+//;
115              
116             my $new_item;
117             while ( not defined $new_item ) {
118             # grab in tolerant mode
119             # print "Grabbing $cmd\n";
120             eval {
121             $new_item = $self->{current_node}->grab( step => $cmd, type => 'node', mode => 'strict', autoadd => 0 );
122             };
123             chop $cmd;
124             }
125              
126             #print "Grab got ",$new_item->location,"\n";
127              
128             my @choice;
129             my $new_type = $new_item->get_type;
130              
131             my @children = $node_only ? $new_item->get_element_name( cargo_type => 'node' )
132             : $new_item->get_element_name();
133             # say "Children: @children";
134             foreach my $elt_name (@children) {
135             if ( $new_item->element_type($elt_name) =~ /^(hash|list)$/ ) {
136             push @choice, "$elt_name:" unless $node_only;
137             foreach my $idx ( $new_item->fetch_element($elt_name)->fetch_all_indexes ) {
138             # my ($idx) = ($raw_idx =~ /([^\n]{1,40})/ );
139             # $idx .= '...' unless $raw_idx eq $idx ;
140             push @choice, "$elt_name:" . ($idx =~ /[^\w._-]/ ? qq("$idx") : $idx );
141             }
142             }
143             else {
144             push @choice, $elt_name;
145             }
146             }
147              
148             # filter possible choices according to input
149             my @ret = grep { /^$text/ } @choice ;
150              
151             return @ret;
152             };
153              
154             # like path completion, but allow only completion on a node
155             my $node_completion_sub = sub {
156             return $path_completion_sub->(@_, 1);
157             };
158              
159             my %completion_dispatch = (
160             cd => $cd_completion_sub,
161             desc => $completion_sub,
162             display => $completion_sub,
163             ll => $ll_completion_sub,
164             ls => $path_completion_sub,
165             tree => $node_completion_sub,
166             info => $path_completion_sub,
167             check => $completion_sub,
168             fix => $fix_completion_sub,
169             clear => $completion_sub,
170             set => $leaf_completion_sub,
171             delete => $leaf_completion_sub,
172             reset => $completion_sub,
173             );
174              
175             my ( $self, $text, $line, $start ) = @_;
176              
177 14     14 0 15729 my $space_idx = index $line, ' ';
178             my ( $main, $cmd ) = split m/\s+/, $line, 2; # /;
179 14         31 #warn " comp main cmd is '$main' (space_idx $space_idx)\n";
180 14         67  
181             if ( $space_idx > 0 and defined $completion_dispatch{$main} ) {
182             my $i = $self->{current_node}->instance;
183 14 100 66     74 # say "Input: ['$text', '$line', $start], ";
    50          
184 13         51  
185             my @choices = $completion_dispatch{$main}->( $self, $text, $line, $start );
186             # say "Choices: ['", join("', '",@choices),"']";
187 13         34 return @choices;
188             }
189 13         39 elsif ( not $cmd ) {
190             return grep { /^$text/ } $self->simple_ui_commands() ;
191             }
192 1         13  
  18         51  
193             return ();
194             }
195 0         0  
196             my $type = shift;
197             my %args = @_;
198              
199 1     1 0 2 my $self = {};
200 1         4  
201             foreach my $p (qw/root title prompt/) {
202 1         3 $self->{$p} = delete $args{$p}
203             or croak "TermUI->new: Missing $p parameter";
204 1         3 }
205 3 50       10  
206             $self->{current_node} = $self->{root};
207              
208             my $term = Term::ReadLine->new( $self->{title} );
209 1         2  
210             my $sub_ref = sub { $self->completion(@_); };
211 1         14  
212             my $word_break_string = "\\\t\n' `\@\$><;|&{(";
213 1     0   273  
  0         0  
214             if ( $term->ReadLine eq "Term::ReadLine::Gnu" ) {
215 1         3  
216             # See Term::ReadLine::Gnu / Custom Completion
217 1 50       4 my $attribs = $term->Attribs;
    50          
218             $attribs->{completion_function} = $sub_ref;
219             $attribs->{completer_word_break_characters} = $word_break_string;
220 0         0 # this method is available only on Term::ReadLine::Gnu > 1.32
221 0         0 $term->enableUTF8 if $term->can('enableUTF8');
222 0         0 }
223             elsif ( $term->ReadLine eq "Term::ReadLine::Perl" ) {
224 0 0       0 no warnings "once";
225             warn "utf-8 support has not beed tested with Term::ReadLine::Perl. ",
226             "You should install Term::ReadLine::Gnu.\n";
227 1     1   8 $readline::rl_completion_function = $sub_ref;
  1         3  
  1         329  
228 0         0 &readline::rl_set( rl_completer_word_break_characters => $word_break_string );
229              
230 0         0 # &readline::rl_set('TcshCompleteMode', 'On');
231 0         0 }
232             else {
233             warn "You should install Term::ReadLine::Gnu for autocompletion and utf-8 support.\n";
234             }
235              
236 1         44 $self->{term} = $term;
237              
238             foreach my $p (qw//) {
239 1         6 $self->{$p} = delete $args{$p} if defined $args{$p};
240             }
241 1         2  
242 0 0       0 bless $self, $type;
243             }
244              
245 1         10 my $self = shift;
246              
247             my $term = $self->{term};
248              
249 0     0 1   my $OUT = $term->OUT || \*STDOUT;
250             my $user_cmd;
251 0           while ( defined( $user_cmd = $term->readline( $self->prompt ) ) ) {
252             last if $user_cmd eq 'exit' or $user_cmd eq 'quit';
253 0   0       $user_cmd = decode_utf8($user_cmd,1);
254 0           #print $OUT "cmd: $user_cmd\n";
255 0           my $res = $self->run($user_cmd);
256 0 0 0       print $OUT $res, "\n" if defined $res and $res;
257 0           ## $term->addhistory($_) if defined $_ && /\S/;
258             }
259 0           print "\n";
260 0 0 0        
261             my $instance = $self->{root}->instance;
262             if ( $instance->c_count ) {
263 0           if ($instance->has_changes) {
264             $instance->say_changes;
265 0           $user_cmd = $term->readline("write back data before exit ? (Y/n)");
266 0 0         $instance->write_back unless $user_cmd =~ /n/i;
267 0 0         print "\n";
268 0           }
269 0           }
270 0 0         }
271 0            
272             1;
273              
274             # ABSTRACT: Interactive command line interface for cme
275              
276              
277             =pod
278              
279             =encoding UTF-8
280              
281             =head1 NAME
282              
283             Config::Model::TermUI - Interactive command line interface for cme
284              
285             =head1 VERSION
286              
287             version 2.151
288              
289             =head1 SYNOPSIS
290              
291             use Config::Model;
292             use Config::Model::TermUI ;
293              
294             # define configuration tree object
295             my $model = Config::Model->new;
296             $model->create_config_class(
297             name => "Foo",
298             element => [
299             [qw/foo bar/] => {
300             type => 'leaf',
301             value_type => 'string'
302             },
303             ]
304             );
305             $model ->create_config_class (
306             name => "MyClass",
307              
308             element => [
309              
310             [qw/foo bar/] => {
311             type => 'leaf',
312             value_type => 'string'
313             },
314             hash_of_nodes => {
315             type => 'hash', # hash id
316             index_type => 'string',
317             cargo => {
318             type => 'node',
319             config_class_name => 'Foo'
320             },
321             },
322             ],
323             ) ;
324              
325             my $inst = $model->instance(root_class_name => 'MyClass' );
326              
327             my $root = $inst->config_root ;
328              
329             # put data
330             my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour -
331             hash_of_nodes:en foo=hello ';
332             $root->load( steps => $steps );
333              
334             my $ui = Config::Model::TermUI->new(
335             root => $root ,
336             title => 'My class ui',
337             prompt => 'class ui',
338             );
339              
340             # engage in user interaction
341             $ui -> run_loop ;
342              
343             print $root->dump_tree ;
344              
345             Once the synopsis above has been saved in C<my_test.pl>, you can achieve the
346             same interactions as with C<Config::Model::SimpleUI>. Except that you can use
347             TAB completion:
348              
349             class ui:$ ls
350             foo bar hash_of_nodes
351             class ui:$ ll hash_of_nodes
352             name value type comment
353             hash_of_nodes <Foo> node hash keys: "en" "fr"
354              
355             class ui:$ cd hash_of_nodes:en
356             class ui: hash_of_nodes:en $ ll
357             name value type comment
358             foo hello string
359             bar [undef] string
360              
361             class ui: hash_of_nodes:en $ set bar=bonjour
362             class ui: hash_of_nodes:en $ ll
363             name value type comment
364             foo hello string
365             bar bonjour string
366              
367             class ui: hash_of_nodes:en $ ^D
368              
369             At the end, the test script dumps the configuration tree. The modified
370             C<bar> value can be found in there:
371              
372             foo=FOO
373             hash_of_nodes:en
374             foo=hello
375             bar=bonjour -
376             hash_of_nodes:fr
377             foo=bonjour - -
378              
379             =head1 DESCRIPTION
380              
381             This module provides a helper to construct pure ASCII user interface
382             on top of L<Term::ReadLine>. To get better interaction you must
383             install either L<Term::ReadLine::Gnu> or L<Term::ReadLine::Perl>.
384              
385             Depending on your installation, either L<Term::ReadLine::Gnu> or
386             L<Term::ReadLine::Perl> is used. See L<Term::ReadLine> to
387             override default choice.
388              
389             =head1 Dependencies
390              
391             This module is optional and depends on L<Term::ReadLine> to work. To
392             reduce the dependency list of L<Config::Model>, C<Term::ReadLine> is
393             only recommended. L<cme> gracefully degrades to
394             L<Config::Model::SimpleUI> when necessary.
395              
396             =head1 USER COMMAND SYNTAX
397              
398             See L<Config::Model::SimpleUI/"USER COMMAND SYNTAX">.
399              
400             =head1 CONSTRUCTOR
401              
402             =head2 parameters
403              
404             =over
405              
406             =item root
407              
408             Root node of the configuration tree
409              
410             =item title
411              
412             UI title
413              
414             =item prompt
415              
416             UI prompt. The prompt will be completed with the location of the
417             current node.
418              
419             =back
420              
421             =head1 Methods
422              
423             =head2 run_loop
424              
425             Engage in user interaction until user enters '^D' (CTRL-D).
426              
427             =head1 BUGS
428              
429             =over
430              
431             =item *
432              
433             Auto-completion is not complete.
434              
435             =item *
436              
437             Auto-completion provides wrong choice when you try to C<cd> in a hash
438             where the index contains a white space. I.e. the correct command is
439             C<cd foo:"a b"> instead of C<cd foo: "a b"> as proposed by auto
440             completion.
441              
442             =back
443              
444             =head1 AUTHOR
445              
446             Dominique Dumont, (ddumont at cpan dot org)
447              
448             =head1 SEE ALSO
449              
450             L<Config::Model>,
451             L<Config::Model::Instance>,
452             L<Config::Model::Node>,
453              
454             =head1 AUTHOR
455              
456             Dominique Dumont
457              
458             =head1 COPYRIGHT AND LICENSE
459              
460             This software is Copyright (c) 2005-2022 by Dominique Dumont.
461              
462             This is free software, licensed under:
463              
464             The GNU Lesser General Public License, Version 2.1, February 1999
465              
466             =cut