File Coverage

blib/lib/App/Dochazka/CLI/Parser.pm
Criterion Covered Total %
statement 85 112 75.8
branch 16 32 50.0
condition 3 6 50.0
subroutine 15 16 93.7
pod 5 5 100.0
total 124 171 72.5


line stmt bran cond sub pod time code
1             # *************************************************************************
2             # Copyright (c) 2014-2016, SUSE LLC
3             #
4             # All rights reserved.
5             #
6             # Redistribution and use in source and binary forms, with or without
7             # modification, are permitted provided that the following conditions are met:
8             #
9             # 1. Redistributions of source code must retain the above copyright notice,
10             # this list of conditions and the following disclaimer.
11             #
12             # 2. Redistributions in binary form must reproduce the above copyright
13             # notice, this list of conditions and the following disclaimer in the
14             # documentation and/or other materials provided with the distribution.
15             #
16             # 3. Neither the name of SUSE LLC nor the names of its contributors may be
17             # used to endorse or promote products derived from this software without
18             # specific prior written permission.
19             #
20             # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21             # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22             # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23             # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
24             # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25             # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26             # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27             # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28             # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29             # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30             # POSSIBILITY OF SUCH DAMAGE.
31             # *************************************************************************
32             #
33             # parser module
34             #
35             package App::Dochazka::CLI::Parser;
36              
37 20     20   528031 use 5.012;
  20         39  
38 20     20   64 use strict;
  20         19  
  20         294  
39 20     20   54 use warnings;
  20         19  
  20         390  
40              
41 20     20   1577 use App::CELL qw( $CELL );
  20         230659  
  20         1334  
42 20     20   5054 use App::Dochazka::CLI qw( $debug_mode );
  20         28  
  20         1471  
43 20     20   7187 use App::Dochazka::CLI::TokenMap qw( $token_map );
  20         28  
  20         1687  
44 20     20   9201 use App::Dochazka::CLI::CommandMap;
  20         53  
  20         1060  
45 20     20   94 use Data::Dumper;
  20         20  
  20         704  
46 20     20   67 use Exporter 'import';
  20         19  
  20         400  
47 20     20   62 use Web::MREST::CLI qw( send_req );
  20         21  
  20         15111  
48              
49              
50             =head1 NAME
51              
52             App::Dochazka::CLI::Parser - Parser module
53              
54              
55              
56             =head1 PACKAGE VARIABLES AND EXPORTS
57              
58             =over
59              
60             =item C<< generate_semantic_tree >>
61              
62             Populate the C<< $semantic_tree >> package variable.
63              
64             =item C<< lookup_command >>
65              
66             =item C<< parse >>
67              
68             Parse the command string entered by the user.
69              
70             =item C<< possible_words >>
71              
72             Given a state expressed as a stack of tokens, return list of possible tokens.
73              
74             =item C<< process_command >>
75              
76             Given a command string, process it (by parsing, calling the handler, etc.) and
77             return the result.
78              
79             =item C<< $semantic_tree >>
80              
81             The semantic tree is a traversable tree representation of the CLI commands,
82             i.e. the keys of the dispatch map C<< $App::Dochazka::CLI::CommandMap::dispatch_map >>
83              
84             =back
85              
86             =cut
87              
88             our @EXPORT_OK = qw(
89             generate_semantic_tree
90             look_up_command
91             parse
92             possible_words
93             process_command
94             $semantic_tree
95             );
96             our $semantic_tree;
97              
98              
99              
100              
101             =head1 FUNCTIONS
102              
103             =head2 generate_semantic_tree
104              
105             Generate the semantic context tree.
106              
107             The set of keys of C<< %$dispatch_map >> contains all the possible commands,
108             each expressed as a sequence of tokens. The semantic context tree is generated
109             from the dispatch map keys. Each node of the tree represents a possible token
110             and the set of nodes at depth n of the tree is the set of possible tokens in
111             the nth position within the command.
112              
113             Taking, for example, a dispatch map consisting of the following two commands:
114              
115             ABE BABEL CAROL
116             DALE EARL JENSEN PARLOR
117             DALE TWIT
118              
119             The semantic tree would be:
120              
121             (root)
122             |
123             +-----------+
124             | |
125             ABE DALE
126             | |
127             | +------+
128             | | |
129             BABEL EARL TWIT
130             | |
131             CAROL JENSEN
132             |
133             PARLOR
134              
135             The point of this exercise is to facilitate command completion. If two a single
136             token ABE has been entered by the user and is pressed, finding out that
137             BABEL is the only possible command in this position is a simple matter of
138             traversing the above semantic tree. (And this is exactly what is done by the
139             C routine in L.)
140              
141             This routine takes an optional argument which, if provided, is assumed to be a
142             reference to a dispatch map. In the absence of this argument, the
143             C<$dispatch_map> package variable (initialized above) is used.
144              
145             For this and more examples, see C.
146              
147             =cut
148              
149             sub generate_semantic_tree {
150 7     7 1 2524 my ( $dm ) = @_;
151             #
152             # ( if $dm is given -- e.g., for testing --, then use it. Otherwise, use
153             # the $dispatch_map package variable )
154             #
155 7 100       18 if ( ! $dm ) {
156 3         6 $dm = $App::Dochazka::CLI::CommandMap::dispatch_map;
157             }
158              
159 7         8 my $tree = {};
160              
161 7         281 foreach my $cmd ( keys %$dm ) {
162            
163             # split the command into tokens
164 1963         2197 my @tokens = split( ' ', $cmd );
165            
166             # walk the tokens - $subtree is a pointer into $tree
167 1963         1486 my $subtree = $tree;
168 1963         2272 for ( my $i = 0; $i < @tokens; $i += 1 ) {
169 7096         4468 my $token = $tokens[$i];
170 7096 100       7701 if ( ! exists( $subtree->{ $token } ) ) {
171             # create new node
172 2432         2259 $subtree->{ $token } = {};
173             }
174             # add child to existing node
175 7096         10040 $subtree = $subtree->{ $token };
176             }
177            
178             }
179              
180             # return the tree we built
181             #print Dumper( $tree ), "\n";
182 7         67 return $tree;
183             }
184              
185              
186             =head2 look_up_command
187              
188             Given a normalized command string such as "GET BUGREPORT", look it up in the
189             dispatch map and return the corresponding coderef, or nothing if the lookup
190             fails.
191              
192             =cut
193              
194             sub look_up_command {
195 805     805 1 3138 my ( $cmd ) = @_;
196              
197             # check for undef and empty string
198 805 50 33     3650 return unless defined( $cmd ) and $cmd =~ m/\S/;
199              
200             # check for a match
201 805 50       2375 if ( my $coderef = $App::Dochazka::CLI::CommandMap::dispatch_map->{ uc( $cmd ) } ) {
202 805         1403 return $coderef;
203             }
204              
205             # failure - return nothing
206 0         0 return;
207             }
208              
209              
210             =head2 parse
211              
212             Parse command string entered by the user. Takes the command string, and returns:
213              
214             =over
215              
216             =item C<< $nc >>
217              
218             The normalized command - suitable for lookup via C
219              
220             =item C<< $ts >>
221              
222             The token stack - a reference to the list of normalized tokens
223              
224             =item C<< $th >>
225              
226             The token hash - a hash where the keys are the normalized tokens and the values
227             are the raw values extracted from the command string. Whatever is left after
228             command string parsing completes will be placed in the '_REMAINDER' key.
229              
230             =back
231              
232             =cut
233              
234             sub parse {
235 815     815 1 349807 my $cmd = shift; # command string entered by user
236 815         908 my $w_cmd = $cmd; # working copy of command string
237 815         1083 my $ts = []; # resulting token stack
238 815         917 my $th = {}; # resulting token hash
239              
240 815         2025 $w_cmd =~ s/^\s+//;
241 815         1749 WHILE1: while ( length( $w_cmd ) > 0 ) {
242            
243             # get list of possible tokens
244 3347         4264 my $poss = possible_words( $ts );
245             #print( "Possible words are " . join( ' ', @$poss ) . "\n" );
246              
247             # match against remaining command string
248 3347         5324 foreach my $key ( @$poss ) {
249              
250             # the key might be, e.g., _TIMESTAMP1 - strip any trailing numerals
251 18841         12239 my $stripped_key = $key;
252 18841         18602 $stripped_key =~ s/\d\z//;
253             #print "Stripped key is $stripped_key\n";
254              
255             # look up the regular expression and apply it to the remaining
256             # command text $w_cmd
257 18841         16342 my $re = $token_map->{ $stripped_key };
258 18841 50       20501 if ( ! $re ) {
259 0         0 die "AGH! Possible token $key has no regular expression assigned";
260             }
261 18841         18111 $re = '\A' . $re . '((\s)|(\z))';
262             #print "Remaining command text: $w_cmd\n";
263 18841         249391 my ( $match ) = $w_cmd =~ m/$re/i;
264              
265 18841 100       41090 if ( $match ) {
266             # the key might already exist in the token hash
267             # e.g. for commands like SCHEDULE _DOW _TIME _DOW _TIME
268 2986         3794 my $safe_key = _get_safe_key( $key, $th );
269 2986         3148 push @$ts, $safe_key;
270 2986         3921 $th->{ $safe_key } = $match;
271             # chomp it off
272 2986         74602 $w_cmd =~ s/$re//i;
273 2986         11758 $w_cmd =~ s/^\s+//;
274             # we have a match for this token - go on to the next
275 2986         9113 next WHILE1;
276             }
277             }
278             # no match found - whatever tokens are in the stack, that is our command
279             # and the rest is the rest
280 361         516 $w_cmd =~ s/^\s+//;
281 361         530 $th->{ '_REST' } = $w_cmd;
282 361         423 last WHILE1;
283             }
284 815 100       1626 $th->{'_REST'} = '' unless exists( $th->{'_REST'} );
285              
286 815         3675 return { ts => $ts, th => $th, nc => join( ' ', @$ts ) };
287             }
288              
289             sub _get_safe_key {
290 2986     2986   2627 my ( $key, $th ) = @_;
291 2986         2206 my $safe_key;
292            
293 2986 50       4228 if ( exists( $th->{$key} ) ) {
294             # cannot put the key into the hash under this name,
295             # because doing so would clobber an existing key
296              
297             # successively try up to nine alternative names
298             BREAK_OUT: {
299 0         0 for ( my $i = 1; $i < 10; $i += 1 ) {
  0         0  
300 0         0 $safe_key = $key . $i;
301 0 0       0 last BREAK_OUT unless exists( $th->{$safe_key} );
302             }
303 0         0 die "AAH! Exceeded nine alternative keys in _get_safe_keys"
304             }
305             } else {
306 2986         2708 $safe_key = $key;
307             }
308              
309             # key is safe
310 2986         3666 return $safe_key;
311             }
312              
313              
314             =head2 possible_words
315              
316             Given a token stack, return the list of possible tokens.
317              
318             =cut
319              
320             sub possible_words {
321 3358     3358 1 6939 my ( $ts ) = @_;
322              
323 3358 100 66     15446 $semantic_tree = generate_semantic_tree() unless defined( $semantic_tree ) and %$semantic_tree;
324              
325 3358         3071 my $pointer = $semantic_tree;
326 3358         6057 for ( my $i = 0 ; $i < @$ts ; $i += 1 ) {
327 5914 100       8145 if ( my $subtree = $pointer->{ $ts->[$i] } ) {
328 5913         8587 $pointer = $subtree;
329             } else {
330             # no possibilities
331 1         3 return [];
332             }
333             }
334              
335 3357         11167 return [ keys( %$pointer ) ];
336             }
337              
338              
339             =head2 process_command
340              
341             Given a command entered by the user, process it and return the result.
342              
343             =cut
344              
345             sub process_command {
346 0     0 1   my ( $cmd ) = @_;
347            
348 0           my $r = parse( $cmd ); # parse the command string
349             # if debug mode, dump parser state
350 0 0         if ( $debug_mode ) {
351 0           print "Recognized command: " . $r->{nc} . "\n";
352 0           print "Token hash: " . Dumper( $r->{th} ) . "\n";
353             }
354 0 0         if ( not @{ $r->{ts} } ) {
  0            
355 0           return $CELL->status_err( 'DOCHAZKA_CLI_PARSE_ERROR' );
356             }
357              
358 0           my $cmdspec = look_up_command( $r->{nc} ); # get the handler coderef
359 0 0         if ( ref( $cmdspec ) eq 'CODE' ) {
360 0           my $rv = $cmdspec->( $r->{ts}, $r->{th} ); # call the handler
361 0 0         if ( ref( $rv ) eq 'ARRAY' ) {
362 0           my $pl;
363 0           my $status = send_req( @$rv ); # call send_req with the args
364 0 0         if ( ref( $status ) eq 'App::CELL::Status' ) {
365 0           $status->{'rest_test'} = 1;
366 0           return $status;
367             } else {
368 0           die "AAAAGGGHGHGHGHGHHHH! \$status is not a status object " . Dumper( $status );
369             }
370             } else {
371 0           return $rv;
372             }
373             }
374 0           return $CELL->status_err( 'DOCHAZKA_CLI_PARSE_ERROR' );
375              
376             }
377              
378             1;