File Coverage

blib/lib/Config/Model/SimpleUI.pm
Criterion Covered Total %
statement 62 80 77.5
branch 9 22 40.9
condition 3 6 50.0
subroutine 14 15 93.3
pod 2 6 33.3
total 90 129 69.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 2     2   14891 use v5.020;
  2         6  
  2         106  
13 2     2   22 use strict;
  2         7  
14 2     2   9 use warnings;
  2         4  
  2         40  
15 2     2   9 use open qw(:std :utf8); # undeclared streams in UTF-8
  2         4  
  2         59  
16 2     2   438 use Encode qw(decode_utf8);
  2         1100  
  2         62  
17 2     2   315 use Regexp::Common qw/delimited/;
  2         4  
  2         142  
18 2     2   1057  
  2         4587  
  2         10  
19             use feature qw/postderef signatures/;
20 2     2   170968 no warnings qw/experimental::postderef experimental::signatures/;
  2         5  
  2         227  
21 2     2   13  
  2         5  
  2         5259  
22             my $syntax = '
23             cd <elt>, cd <elt:key>, cd - , cd !
24             -> jump into node
25             set elt=value, elt:key=value
26             -> set a value
27             clear elt
28             -> clear value or list or hash
29             delete elt:key
30             -> delete a value from a list or hash element
31             delete elt
32             -> like reset, delete a value (set to undef)
33             display elt elt:key
34             -> display a value
35             ls -> show content of object (args: path and/or filter pattern)
36             ls -> show elements of current node
37             ls foo* -> shows element matching foo.*
38             ls \'foo*\' -> shows elements of node stored in "foo*"
39             ls aHash -> shows keys of Hash
40             ls \'aHash:"*"\' -> shows elements of node stored in key "*" of "aHash" hash
41             ll [-nz] [-v] [ element | pattern ]
42             -> show elements of current node and their value
43             (options: -nz → hides empty value, -v → verbose)
44             (args: element name or filter pattern)
45             info -> show detailed information on object or current node
46             (args: optional path to object)
47             tree -> show configuration tree from an object or current node
48             (args: optional path to object)
49             help -> show available command
50             desc[ription] -> show class desc of current node
51             desc <element> -> show desc of element from current node
52             desc <value> -> show effect of value (for enum)
53             changes -> list unsaved changes
54             check [elt] -> run check current on current node or elt
55             fix [ ! | elt ]
56             -> fix warnings in current node or of specified element or on all tree (with ! arg)
57             save -> save current changes
58             exit -> exit shell
59             ';
60              
61             my $desc_sub = sub {
62             my $self = shift;
63             my $obj = $self->{current_node};
64             my $res = '';
65              
66             if (@_) {
67             my $item;
68             while ( $item = shift ) {
69             if ( $obj->get_type() eq 'node' ) {
70             my $type = $obj->element_type($item);
71             my $elt = $obj->fetch_element($item);
72             my $help = $obj->get_help_as_text($item);
73             $res .= "element $item (type $type)";
74             $res .= ": " if $help;
75             $res .= "\n" if $help =~ /\n/ or length($help) > 40 ;
76             $res .= $help . "\n" if $help;
77             if ( $type eq 'leaf' and $elt->value_type eq 'enum' ) {
78             $res .= " possible values: " . join( ', ', $elt->get_choice ) . "\n";
79             }
80             }
81             }
82             }
83             else {
84             $res = $obj->get_help_as_text();
85             }
86             return $res;
87             };
88              
89             my $ll_sub = sub {
90             my $self = shift;
91             my @raw_args = @_;
92              
93             my @desc_opt = qw/check no/;
94              
95             my %opt = map { /^-(\w+)/ ? ($1 => 1) : () } @raw_args;
96             push @desc_opt, hide_empty => 1 if $opt{nz} ;
97             push @desc_opt, verbose => 1 if $opt{v} ;
98              
99             my @args = grep {! /^-/ } @raw_args;
100             push @args, '*' unless @args; # default action is to list all elements
101              
102             my $obj = $self->{current_node};
103             for (@args) {s/\*/.*/g;} ;
104             my $pattern = join ('|',@args);
105              
106             return $obj->describe( pattern => qr/^$pattern$/, @desc_opt );
107             };
108              
109             my $cd_sub = sub {
110             my $self = shift;
111             my @cmds = @_;
112              
113             # convert usual cd_ism ( .. /foo) to grab syntax ( - ! foo)
114             #map { s(^/) (! );
115             # s(\.\.)(-)g;
116             # s(/) ( )g;
117             # } @cmds ;
118              
119             my $new_node = $self->{current_node}->grab("@cmds");
120             my $type = $new_node->get_type;
121             my $name = $new_node->element_name;
122              
123             if ( defined $new_node && $type eq 'node' ) {
124             $self->{current_node} = $new_node;
125             }
126             elsif ( defined $new_node && $type eq 'list' ) {
127             print "Can't cd in a $type, please add an index (e.g. $name:0)\n";
128             }
129             elsif ( defined $new_node && $type eq 'hash' ) {
130             print "Can't cd in a $type, please add an index (e.g. $name:foo)\n";
131             }
132             elsif ( defined $new_node && $type eq 'leaf' ) {
133             print "Can't cd in a $type\n";
134             }
135             else {
136             print "Cannot find @_\n";
137             }
138              
139             return "";
140             };
141              
142             my %run_dispatch = (
143             help => sub { return $syntax; },
144             set => sub {
145             my $self = shift;
146             if (@_) {
147             $self->{current_node}->load(join('',@_));
148             }
149             else {
150             say "No command given.";
151             }
152             return "";
153             },
154             display => sub ($self, @args) {
155             unless (@args) {
156             say "Nothing to display";
157             return;
158             }
159             return $self->{current_node}->grab_value(@args);
160             },
161             info => sub {
162             my $self = shift;
163             my $cnode = $self->{current_node};
164             my $target = @_ ? $cnode->grab(steps => [@_]) : $cnode;
165             return join("\n", $target->get_info );
166             },
167             ls => sub {
168             my $self = shift;
169             my $target = $self->{current_node};
170             my $pattern = '*';
171             for (@_) {
172             if (/\*/ and not /^["']/) {
173             $pattern = $_;
174             last;
175             }
176             $target = $target->grab(steps => $_);
177             }
178             $pattern =~ s/\*/.*/g;
179              
180             my $i = $self->{current_node}->instance;
181             my @res = $target->can('children') ? grep {/^$pattern$/} $target->children : ();
182             return join( ' ', @res );
183             },
184             tree => sub {
185             my $self = shift;
186             my $i = $self->{current_node}->instance;
187             my $cnode = $self->{current_node};
188             my $target = @_ ? $cnode->grab(steps => [@_]) : $cnode;
189             my @res = $target->dump_tree( mode => 'user' );
190             return join( ' ', @res );
191             },
192             delete => sub {
193             my $self = shift;
194             if ($_[0]) {
195             my ( $elt_name, $key ) = split /\s*:\s*/, $_[0];
196             my $elt = $self->{current_node}->fetch_element($elt_name);
197             if ( length($key) ) {
198             $elt->delete($key);
199             }
200             else {
201             $elt->store(undef);
202             }
203             }
204             else {
205             say "delete what ?";
206             }
207             return '';
208             },
209             clear => sub {
210             my ( $self, $elt_name ) = @_;
211             if ($elt_name) {
212             $self->{current_node}->fetch_element($elt_name)->clear();
213             }
214             else {
215             say "Expected element name for clear command. I.e. one of ",
216             join(' ',$self->{current_node}->get_element_name);
217             }
218             return '';
219             },
220             check => sub {
221             my ( $self, $elt_name ) = @_;
222             if ($elt_name) {
223             $self->{current_node}->fetch_element($elt_name)->check();
224             }
225             else {
226             $self->{current_node}->check;
227             }
228             return '';
229             },
230             fix => sub {
231             my ( $self, $elt_name ) = @_;
232             if ($elt_name eq '!') {
233             $self->{root}->instance->apply_fixes;
234             }
235             elsif ($elt_name) {
236             $self->{current_node}->fetch_element($elt_name)->apply_fixes;
237             }
238             else {
239             $self->{current_node}->apply_fixes;
240             }
241             return '';
242             },
243             save => sub {
244             my ($self) = @_;
245             $self->{root}->instance->write_back();
246             return "done";
247             },
248             changes => sub {
249             my ( $self ) = @_;
250             return $self->{root}->instance->list_changes;
251             },
252             ll => $ll_sub,
253             cd => $cd_sub,
254             description => $desc_sub,
255             desc => $desc_sub,
256             );
257              
258             $run_dispatch{reset} = $run_dispatch{clear};
259             $run_dispatch{dump} = $run_dispatch{tree};
260              
261             my @cmds = sort keys %run_dispatch;
262             return @cmds;
263 1     1 0 13 }
264 1         5  
265             my $type = shift;
266             my %args = @_;
267              
268 1     1 0 3 my $self = {};
269 1         7  
270             foreach my $p (qw/root title prompt/) {
271 1         2 $self->{$p} = delete $args{$p}
272             or croak "SimpleUI->new: Missing $p parameter";
273 1         3 }
274 3 50       11  
275             $self->{current_node} = $self->{root};
276              
277             bless $self, $type;
278 1         5 }
279              
280 1         4 my $self = shift;
281              
282             my $user_cmd;
283             print $self->prompt;
284 0     0 1 0 while ( defined( $user_cmd = <STDIN> ) ) {
285             chomp $user_cmd;
286 0         0 last if $user_cmd eq 'exit' or $user_cmd eq 'quit';
287 0         0 my $res = $self->run($user_cmd);
288 0         0 print $res, "\n" if defined $res;
289 0         0 print $self->prompt;
290 0 0 0     0 }
291 0         0 print "\n";
292 0 0       0  
293 0         0 my $instance = $self->{root}->instance;
294             if ( $instance->c_count ) {
295 0         0 if ($instance->has_changes) {
296             $instance->say_changes;
297 0         0 print "write back data before exit ? (Y/n)";
298 0 0       0 $user_cmd = <STDIN>;
299 0 0       0 $instance->write_back unless $user_cmd =~ /n/i;
300 0         0 print "\n";
301 0         0 }
302 0         0 }
303 0 0       0  
304 0         0 }
305              
306             my $self = shift;
307             my $ret = $self->{prompt} . ':';
308             my $loc = $self->{current_node}->location_short;
309             $ret .= " $loc " if $loc;
310             return $ret . '$ ';
311 11     11 1 9294 }
312 11         46  
313 11         109 my ( $self, $user_cmd ) = @_;
314 11 100       41  
315 11         60 return '' unless $user_cmd =~ /\w/;
316              
317             my $re = $RE{delimited}{-delim=>q{'"}};
318             my ( $action, @args ) = ( $user_cmd =~ /((?:[^\s"']|$re)+)/g );
319 10     10 0 5097  
320             if ( defined $run_dispatch{$action} ) {
321 10 50       74 my $res;
322             my $ok = eval {
323 10         102 $res = $run_dispatch{$action}->( $self, @args );
324 10         605 1;
325             };
326 10 100       1888 say $@->message unless $ok;
327 9         24 return $res;
328 9         23 }
329 9         52 else {
330 9         28 return "Unexpected command '$action'";
331             }
332 9 50       31 }
333 9         68  
334             my $self = shift;
335             my $c_node = $self->{current_node};
336 1         9  
337             my @result;
338             foreach my $elt_name ( $c_node->get_element_name ) {
339             my $t = $c_node->element_type($elt_name);
340              
341 1     1 0 269 if ( $t eq 'list' or $t eq 'hash' ) {
342 1         2 push @result,
343             map { "$elt_name:$_" } $c_node->fetch_element($elt_name)->fetch_all_indexes;
344 1         3 }
345 1         6 else {
346 18         38 push @result, $elt_name;
347             }
348 18 100 100     47 }
349              
350 7         19 return \@result;
  2         10  
351             }
352             1;
353 11         24  
354             #ABSTRACT: Simple interface for Config::Model
355              
356              
357 1         7 =pod
358              
359             =encoding UTF-8
360              
361             =head1 NAME
362              
363             Config::Model::SimpleUI - Simple interface for Config::Model
364              
365             =head1 VERSION
366              
367             version 2.151
368              
369             =head1 SYNOPSIS
370              
371             use Config::Model;
372             use Config::Model::SimpleUI ;
373              
374             # define configuration tree object
375             my $model = Config::Model->new;
376             $model->create_config_class(
377             name => "Foo",
378             element => [
379             [qw/foo bar/] => {
380             type => 'leaf',
381             value_type => 'string'
382             },
383             ]
384             );
385             $model ->create_config_class (
386             name => "MyClass",
387              
388             element => [
389              
390             [qw/foo bar/] => {
391             type => 'leaf',
392             value_type => 'string'
393             },
394             hash_of_nodes => {
395             type => 'hash', # hash id
396             index_type => 'string',
397             cargo => {
398             type => 'node',
399             config_class_name => 'Foo'
400             },
401             },
402             ],
403             ) ;
404              
405             my $inst = $model->instance(root_class_name => 'MyClass' );
406              
407             my $root = $inst->config_root ;
408              
409             # put data
410             my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour -
411             hash_of_nodes:en foo=hello ';
412             $root->load( steps => $steps );
413              
414             my $ui = Config::Model::SimpleUI->new(
415             root => $root ,
416             title => 'My class ui',
417             prompt => 'class ui',
418             );
419              
420             # engage in user interaction
421             $ui -> run_loop ;
422              
423             print $root->dump_tree ;
424              
425             Once the synopsis above has been saved in C<my_test.pl>, you can do:
426              
427             $ perl my_test.pl
428             class ui:$ ls
429             foo bar hash_of_nodes
430             class ui:$ ll hash_of_nodes
431             name value type comment
432             hash_of_nodes <Foo> node hash keys: "en" "fr"
433              
434             class ui:$ cd hash_of_nodes:en
435              
436             class ui: hash_of_nodes:en $ ll
437             name value type comment
438             foo hello string
439             bar [undef] string
440              
441             class ui: hash_of_nodes:en $ set bar=bonjour
442              
443             class ui: hash_of_nodes:en $ ll
444             name value type comment
445             foo hello string
446             bar bonjour string
447              
448             class ui: hash_of_nodes:en $ ^D
449              
450             At the end, the test script dumps the configuration tree. The modified
451             C<bar> value can be found in there:
452              
453             foo=FOO
454             hash_of_nodes:en
455             foo=hello
456             bar=bonjour -
457             hash_of_nodes:fr
458             foo=bonjour - -
459              
460             =head1 DESCRIPTION
461              
462             This module provides a pure ASCII user interface using STDIN and
463             STDOUT.
464              
465             =head1 USER COMMAND SYNTAX
466              
467             =over
468              
469             =item cd ...
470              
471             Jump into node or value element. You can use C<< cd <element> >>,
472             C<< cd <elt:key> >> or C<cd -> to go up one node or C<cd !>
473             to go to configuration root.
474              
475             =item set elt=value
476              
477             Set a leaf value.
478              
479             =item set elt:key=value
480              
481             Set a leaf value locate in a hash or list element.
482              
483             =item clear elt
484              
485             Clear leaf value (set to C<undef>) or removed all elements of hash or list.
486              
487             =item delete elt
488              
489             Delete leaf value.
490              
491             =item delete elt:key
492              
493             Delete a list or hash element
494              
495             =item display node_name elt:key
496              
497             Display a value
498              
499             =item ls [path] [ pattern ]
500              
501             Show elements of current node or of a node pointed by path. Elements
502             can be filtered with a shell pattern. See inline help for more details.
503              
504             =item ll [-nz] [-v] [ pattern ... ]
505              
506             Describe elements of current node. Can be used with shell patterns or element names.
507             Skip empty element with C<-nz> option. Display more information with C<-v> option
508              
509             =item tree [path]
510              
511             Show configuration tree from current node or of a node pointed by path.
512              
513             =item info [path]
514              
515             Show debug information on current node or on the element pointed by
516             path. The debug information may show model parametersm default or computed
517             values.
518              
519             =item help
520              
521             Show available commands.
522              
523             =item desc[ription]
524              
525             Show class description of current node.
526              
527             =item desc(elt)
528              
529             Show description of element from current node.
530              
531             =item desc(value)
532              
533             Show effect of value (for enum)
534              
535             =item changes
536              
537             Show unsaved changes
538              
539             =item check
540              
541             Without parameter, show warnings starting from current node. With an
542             element name as parameter, do the same on the element.
543              
544             =item fix
545              
546             Try to fix warning starting from current node. With an element name as parameter,
547             do the same on the element. With "C<!>" as parameter, try to fix warnings starting
548             from root node by calling L<apply_fixes|Config::Model::Instance/apply_fixes> there.
549              
550             =item exit
551              
552             Exit shell
553              
554             =back
555              
556             =head1 CONSTRUCTOR
557              
558             =head2 parameters
559              
560             =over
561              
562             =item root
563              
564             Root node of the configuration tree
565              
566             =item title
567              
568             UI title
569              
570             =item prompt
571              
572             UI prompt. The prompt will be completed with the location of the
573             current node.
574              
575             =back
576              
577             =head1 Methods
578              
579             =head2 run_loop
580              
581             Engage in user interaction until user enters '^D' (CTRL-D).
582              
583             =head1 AUTHOR
584              
585             Dominique Dumont, (ddumont at cpan dot org)
586              
587             =head1 SEE ALSO
588              
589             L<Config::Model>,
590             L<Config::Model::Instance>,
591             L<Config::Model::Node>,
592              
593             =head1 AUTHOR
594              
595             Dominique Dumont
596              
597             =head1 COPYRIGHT AND LICENSE
598              
599             This software is Copyright (c) 2005-2022 by Dominique Dumont.
600              
601             This is free software, licensed under:
602              
603             The GNU Lesser General Public License, Version 2.1, February 1999
604              
605             =cut