File Coverage

blib/lib/Bat/Interpreter.pm
Criterion Covered Total %
statement 264 282 93.6
branch 88 108 81.4
condition 16 23 69.5
subroutine 25 25 100.0
pod 1 1 100.0
total 394 439 89.7


line stmt bran cond sub pod time code
1             package Bat::Interpreter;
2              
3 22     22   1680997 use utf8;
  22         251  
  22         140  
4              
5 22     22   1351 use 5.014;
  22         115  
6 22     22   13114 use Moo;
  22         262780  
  22         107  
7 22     22   46004 use Types::Standard qw(ConsumerOf);
  22         1704190  
  22         258  
8 22     22   30911 use App::BatParser 0.011;
  22         2269466  
  22         797  
9 22     22   191 use Carp;
  22         50  
  22         1454  
10 22     22   149 use Data::Dumper;
  22         50  
  22         998  
11 22     22   10341 use Bat::Interpreter::Delegate::FileStore::LocalFileSystem;
  22         84  
  22         844  
12 22     22   10314 use Bat::Interpreter::Delegate::Executor::PartialDryRunner;
  22         72  
  22         813  
13 22     22   10667 use Bat::Interpreter::Delegate::LineLogger::Silent;
  22         63  
  22         777  
14 22     22   157 use namespace::autoclean;
  22         41  
  22         93  
15              
16             our $VERSION = '0.022'; # VERSION
17              
18             # ABSTRACT: Pure perl interpreter for a small subset of bat/cmd files
19              
20             has 'batfilestore' => (
21             is => 'rw',
22             isa => ConsumerOf ['Bat::Interpreter::Role::FileStore'],
23             default => sub {
24             Bat::Interpreter::Delegate::FileStore::LocalFileSystem->new;
25             }
26             );
27              
28             has 'executor' => (
29             is => 'rw',
30             isa => ConsumerOf ['Bat::Interpreter::Role::Executor'],
31             default => sub {
32             Bat::Interpreter::Delegate::Executor::PartialDryRunner->new;
33             }
34             );
35              
36             has 'linelogger' => (
37             is => 'rw',
38             isa => ConsumerOf ['Bat::Interpreter::Role::LineLogger'],
39             default => sub {
40             Bat::Interpreter::Delegate::LineLogger::Silent->new;
41             }
42             );
43              
44             sub run {
45 23     23 1 2462 my $self = shift();
46 23         66 my $filename = shift();
47 23   100     197 my $external_env = shift() // \%ENV;
48              
49 23         254 my $parser = App::BatParser->new;
50              
51 23         23292 my $ensure_last_line_has_carriage_return = "\r\n";
52 23 50       140 if ( $^O eq 'MSWin32' ) {
53 0         0 $ensure_last_line_has_carriage_return = "\n";
54             }
55              
56 23         524 my $parse_tree =
57             $parser->parse( $self->batfilestore->get_contents($filename) . $ensure_last_line_has_carriage_return );
58 23 50       494906 if ($parse_tree) {
59 23         101 my $lines = $parse_tree->{'File'}{'Lines'};
60              
61 23         692 my %environment = %$external_env;
62              
63             # Index file based on labels
64             #Only for perl >= 5.020
65             #my %line_from_label = List::AllUtils::pairmap { $b->{'Label'}{'Identifier'} => $a }
66             #%{$lines}[ List::AllUtils::indexes { exists $_->{'Label'} } @$lines ];
67 23         85 my %line_from_label;
68 23         142 for ( my $i = 0; $i < scalar @$lines; $i++ ) {
69 150         234 my $line = $lines->[$i];
70 150 100       412 if ( exists $line->{'Label'} ) {
71 21         99 $line_from_label{ $line->{'Label'}{'Identifier'} } = $i;
72             }
73             }
74 23         85 $line_from_label{'EOF'} = scalar @$lines;
75 23         78 $line_from_label{'eof'} = scalar @$lines;
76 23         167 my $context = { 'ENV' => \%environment,
77             'IP' => 0,
78             'LABEL_INDEX' => \%line_from_label,
79             'current_line' => '',
80             'STACK' => []
81             };
82              
83             # Execute lines in a nonlinear fashion
84 23         166 for ( my $instruction_pointer = 0; $instruction_pointer < scalar @$lines; ) {
85 131         261 my $current_instruction = $lines->[$instruction_pointer];
86 131         269 $context->{'IP'} = $instruction_pointer;
87 131         192 my $old_ip = $instruction_pointer;
88 131         405 $self->_handle_instruction( $current_instruction, $context );
89 131         217 $instruction_pointer = $context->{'IP'};
90 131 100       298 if ( $old_ip == $instruction_pointer ) {
91 107         160 $instruction_pointer++;
92             }
93 131         312 $self->_log_line_from_context($context);
94             }
95 23         916 return $context->{'STDOUT'};
96             } else {
97 0         0 die "An error ocurred parsing the file";
98             }
99             }
100              
101             sub _handle_instruction {
102 131     131   206 my $self = shift();
103 131         201 my $current_instruction = shift();
104 131         201 my $context = shift();
105              
106 131         310 my ($type) = keys %$current_instruction;
107              
108 131 100       368 if ( $type eq 'Comment' ) {
109 4         12 $context->{'current_line'} = ":: " . $current_instruction->{'Comment'}{'Text'};
110             }
111              
112 131 100       337 if ( $type eq 'Label' ) {
113 21         80 $context->{'current_line'} = ":" . $current_instruction->{'Label'}{'Identifier'};
114             }
115              
116 131 100       326 if ( $type eq 'Statement' ) {
117 106         191 my $statement = $current_instruction->{'Statement'};
118 106         265 $self->_handle_statement( $statement, $context );
119             }
120              
121             }
122              
123             sub _handle_statement {
124 132     132   216 my $self = shift();
125 132         250 my $statement = shift();
126 132         622 my $context = shift();
127              
128 132         400 my ($type) = keys %$statement;
129              
130 132 50       511 if ( $type eq 'Command' ) {
131 132         327 my $command = $statement->{'Command'};
132 132         325 $self->_handle_command( $command, $context );
133             }
134              
135             }
136              
137             sub _handle_command {
138 132     132   220 my $self = shift();
139 132         228 my $command = shift();
140 132         557 my $context = shift();
141              
142 132 50 33     660 if ( defined $command && $command ne '' ) {
143 132         316 my ($type) = keys %$command;
144              
145 132 100       318 if ( $type eq 'SimpleCommand' ) {
146 29         77 my $command_line = $command->{'SimpleCommand'};
147 29         85 $command_line = $self->_variable_substitution( $command_line, $context );
148              
149             # Path adjustment
150 29         102 $command_line = $self->_adjust_path($command_line);
151              
152 29         87 $context->{'current_line'} .= $command_line;
153              
154 29 100       149 if ( $command_line =~ /^exit\s+\/b/i ) {
155 1         3 my $stack_frame = pop @{ $context->{'STACK'} };
  1         3  
156 1 50       4 if ( defined $stack_frame ) {
157 1         3 $context->{'IP'} = $stack_frame->{'IP'} + 1;
158             }
159             } else {
160 28         100 $self->_execute_command( $command_line, $context );
161             }
162             }
163 132 100       354 if ( $type eq 'SpecialCommand' ) {
164 103         177 my $special_command_line = $command->{'SpecialCommand'};
165 103         342 $self->_handle_special_command( $special_command_line, $context );
166             }
167             } else {
168              
169             # Empty command
170 0         0 $context->{'current_line'} .= '';
171             }
172              
173             }
174              
175             sub _handle_special_command {
176 103     103   165 my $self = shift();
177 103         156 my $special_command_line = shift();
178 103         142 my $context = shift();
179              
180 103         251 my ($type) = keys %$special_command_line;
181              
182 103 100       263 if ( $type eq 'If' ) {
183 25         74 $context->{'current_line'} .= 'IF ';
184 25         53 my $condition;
185             my $statement;
186 25 100       83 if ( exists $special_command_line->{$type}->{'NegatedCondition'} ) {
187 3         8 $context->{'current_line'} .= 'NOT ';
188 3         9 $condition = $special_command_line->{$type}->{'NegatedCondition'}->{'Condition'};
189 3         8 $statement = $special_command_line->{$type}->{'Statement'};
190 3 50       13 if ( not $self->_handle_condition( $condition, $context ) ) {
191 3         14 $self->_handle_statement( $statement, $context );
192             }
193             } else {
194 22         54 ( $condition, $statement ) = @{ $special_command_line->{'If'} }{ 'Condition', 'Statement' };
  22         87  
195 22 100       85 if ( $self->_handle_condition( $condition, $context ) ) {
196 16         101 $self->_handle_statement( $statement, $context );
197             }
198             }
199              
200             }
201              
202 103 100       240 if ( $type eq 'Goto' ) {
203 21         73 my $label = $special_command_line->{'Goto'}{'Identifier'};
204 21         72 $context->{'current_line'} .= 'GOTO ' . $label;
205 21         91 $self->_goto_label( $label, $context, 0 );
206             }
207              
208 103 100       228 if ( $type eq 'Call' ) {
209 4         16 my $token = $special_command_line->{'Call'}{'Token'};
210 4         18 $token = $self->_variable_substitution( $token, $context );
211 4         19 $token = $self->_adjust_path($token);
212 4         17 $context->{'current_line'} .= 'CALL ' . $token;
213 4 100       22 if ( $token =~ /^:/ ) {
214 2         10 $self->_goto_label( $token, $context, 1 );
215             } else {
216 2         12 ( my $first_word ) = $token =~ /\A([^:\s]+)/;
217 2 50       15 if ( $first_word =~ /(\.[^.]+)$/ ) {
218 2         10 ( my $extension ) = $first_word =~ /(\.[^.]+)$/;
219 2 50 33     19 if ( $extension eq '.exe' ) {
    50          
220 0         0 $self->_execute_command( $token, $context );
221             } elsif ( $extension eq '.bat' || $extension eq '.cmd' ) {
222 2         9 $self->_log_line_from_context($context);
223 2         17 my $stdout = $self->run( $token, $context->{ENV} );
224 2 50       9 if ( !defined $context->{STDOUT} ) {
225 2         7 $context->{STDOUT} = [];
226             }
227 2 50       9 if ( defined $stdout ) {
228 0         0 push @{ $context->{STDOUT} }, @$stdout;
  0         0  
229             }
230             }
231             }
232             }
233             }
234              
235 103 100       229 if ( $type eq 'Set' ) {
236 23         57 my ( $variable, $value ) = @{ $special_command_line->{'Set'} }{ 'Variable', 'Value' };
  23         101  
237 23         102 $value = $self->_variable_substitution( $value, $context );
238 23         88 $value = $self->_adjust_path($value);
239 23         100 $context->{'current_line'} .= 'SET ' . $variable . '=' . $value;
240 23         99 $context->{ENV}{$variable} = $value;
241             }
242              
243 103 100       233 if ( $type eq 'For' ) {
244 3         10 $context->{'current_line'} .= 'FOR ';
245 3         7 my $token = $special_command_line->{'For'}{'Token'};
246              
247             # Handle only simple cases
248 3 100       37 if ( $token =~ /\s*?\/F\s*?"delims="\s*%%(?[A-Z0-9]+?)\s*?in\s*?\('(?.+)'\)/i ) {
    50          
249 1         8 my $comando = $+{'comando'};
250 1         6 my $parameter_name = $+{'variable_bucle'};
251 1         4 $comando = $self->_variable_substitution( $comando, $context );
252 1         3 $comando = $self->_adjust_path($comando);
253 1         4 $comando =~ s/%%/%/g;
254              
255 1         5 $context->{'current_line'} .= '/F "delims="' . $parameter_name . ' in ' . "'$comando' ";
256 1         3 my $salida = $self->_for_command_evaluation($comando);
257              
258 1         22 my $statement = $special_command_line->{'For'}{'Statement'};
259              
260 1         22 $context->{'PARAMETERS'}{$parameter_name} = $salida;
261              
262 1         29 $self->_handle_statement( $statement, $context );
263 1         13 delete $context->{'PARAMETERS'}{$parameter_name};
264             } elsif ( $token =~ /\s*?%%(?[A-Z0-9]+?)\s*?in\s*?(\([\d]+(?:,[^,\s]+)+\))/i ) {
265 2         6 my $statement = $special_command_line->{'For'}{'Statement'};
266 2         26 my $parameter_name = $+{'variable_bucle'};
267 2         10 my $value_list = $2;
268 2         19 $value_list =~ s/(\(|\))//g;
269 2         14 my @values = split( /,/, $value_list );
270 2         7 $context->{'current_line'} .= $token . ' do ';
271 2         8 for my $value (@values) {
272 6         16 $context->{'PARAMETERS'}->{$parameter_name} = $value;
273 6         11 $context->{'current_line'} .= "\n\t";
274 6         20 $self->_handle_statement( $statement, $context );
275 6         17 delete $context->{'PARAMETERS'}{$parameter_name};
276             }
277              
278             } else {
279 0         0 Carp::confess('FOR functionality not implemented!');
280             }
281             }
282              
283 103 100       338 if ( $type eq 'Echo' ) {
284 27         86 $context->{'current_line'} .= 'ECHO ';
285 27         65 my $echo = $special_command_line->{'Echo'};
286 27 100       94 if ( exists $echo->{'EchoModifier'} ) {
287 23         111 $context->{'current_line'} .= $echo->{'EchoModifier'};
288             } else {
289 4         10 my $message = $echo->{'Message'};
290 4         18 $message = $self->_variable_substitution( $message, $context );
291 4         19 $context->{'current_line'} .= $message;
292             }
293             }
294             }
295              
296             sub _handle_condition {
297 25     25   53 my $self = shift();
298 25         48 my $condition = shift();
299 25         52 my $context = shift();
300              
301 25         66 my ($type) = keys %$condition;
302 25 100       86 if ( $type eq 'Comparison' ) {
    50          
303             my ( $left_operand, $operator, $right_operand ) =
304 21         46 @{ $condition->{'Comparison'} }{qw(LeftOperand Operator RightOperand)};
  21         89  
305              
306 21         66 $left_operand = $self->_variable_substitution( $left_operand, $context );
307 21         68 $right_operand = $self->_variable_substitution( $right_operand, $context );
308              
309 21         85 $context->{'current_line'} .= $left_operand . ' ' . $operator . ' ' . $right_operand . ' ';
310              
311 21         65 my $uppercase_operator = uc($operator);
312 21 100 100     173 if ( $operator eq '==' || $uppercase_operator eq 'EQU' ) {
    100          
    100          
    100          
    100          
    50          
313 7         46 my $a = $left_operand =~ s/\s*(.*)\s*/$1/r;
314 7         38 my $b = $right_operand =~ s/\s*(.*)\s*/$1/r;
315 7         43 return $a eq $b;
316             } elsif ( $uppercase_operator eq 'NEQ' ) {
317 2         10 return $left_operand != $right_operand;
318             } elsif ( $uppercase_operator eq 'LSS' ) {
319 1         5 return $left_operand < $right_operand;
320             } elsif ( $uppercase_operator eq 'LEQ' ) {
321 2         10 return $left_operand <= $right_operand;
322             } elsif ( $uppercase_operator eq 'GTR' ) {
323 2         13 return $left_operand > $right_operand;
324             } elsif ( $uppercase_operator eq 'GEQ' ) {
325 7         33 return $left_operand >= $right_operand;
326              
327             } else {
328 0         0 die "Operator: $operator not implemented";
329             }
330             } elsif ( $type eq 'Exists' ) {
331 4         6 my $path = ${ $condition->{'Exists'} }{'Path'};
  4         10  
332 4         16 $path = $self->_variable_substitution( $path, $context );
333 4         13 $path = $self->_adjust_path($path);
334 4         14 $context->{'current_line'} .= 'EXIST ' . $path;
335 4         151 return -e $path;
336             } else {
337 0         0 die "Condition type $type not implemented";
338             }
339 0         0 return 0;
340             }
341              
342             sub _variable_substitution {
343 107     107   168 my $self = shift();
344 107         182 my $string = shift();
345 107         153 my $context = shift();
346              
347 107 50       262 if ( !defined $context ) {
348 0         0 Carp::cluck "Please provide a context for variable substitution";
349             }
350              
351 107         233 my $parameters = $context->{'PARAMETERS'};
352 107 100 100     357 if ( defined $parameters && scalar keys %$parameters > 0 ) {
353              
354             my $handle_parameter_sustitution = sub {
355 7     7   27 my $parameter_name = shift();
356 7 50       22 if ( exists $parameters->{$parameter_name} ) {
357 7         44 return $parameters->{$parameter_name};
358             } else {
359 0         0 Carp::cluck "Parameter not defined: $parameter_name";
360 0         0 return '';
361             }
362 14         71 };
363 14         75 $string =~ s/%%([A-Za-z])/$handle_parameter_sustitution->($1)/eg;
  7         29  
364             }
365              
366             my $handle_variable_manipulations = sub {
367 39     39   90 my $variable_name = shift();
368 39         76 my $manipulation = shift();
369              
370 39 100 66     161 if ( defined $variable_name && $variable_name ne '' ) {
371              
372 27         78 my $result = $context->{'ENV'}{$1};
373 27 50       66 if ( defined $result ) {
374 27 100 66     121 if ( defined $manipulation && $manipulation ne '' ) {
375 5         19 $manipulation =~ s/^://;
376 5 100       34 if ( $manipulation =~ /^~(?\d+),(?\d+)$/ ) {
    100          
    50          
377 2         22 $result = substr( $result, $+{'from'}, $+{'length'} );
378             } elsif ( $manipulation =~ /^~(?-\d+),(?\d+)$/ ) {
379 1         15 $result = substr( $result, $+{'from_end'}, $+{'length'} );
380             } elsif ( $manipulation =~ /^\~(\-\d)+$/ ) {
381 2         10 $result = substr( $result, $1 );
382             } else {
383 0         0 Carp::cluck
384             "Variable manipulation not understood: $manipulation over variable: $variable_name. Returning unchanged variable: $result";
385 0         0 return $result;
386             }
387             }
388 27         117 return $result;
389             } else {
390 0         0 Carp::cluck("Variable: $variable_name not defined");
391             }
392 0         0 return '';
393             } else {
394 12         53 return '%%';
395             }
396 107         540 };
397              
398 107         390 $string =~ s/%([\w\#\$\'\(\)\*\+\,\-\.\?\@\[\]\`\{\}\~]*?)(:.+?)?%/$handle_variable_manipulations->($1, $2)/eg;
  39         108  
399              
400 107         204 $string =~ s/%%/%/g;
401              
402 107         782 return $string;
403             }
404              
405             sub _adjust_path {
406 61     61   112 my $self = shift();
407 61         103 my $path = shift();
408 61 50       267 if ( !( $^O =~ 'Win' ) ) {
409 61         141 $path =~ s/\\/\//g;
410             }
411 61         132 return $path;
412             }
413              
414             sub _execute_command {
415 28     28   69 my $self = shift();
416 28         643 $self->executor->execute_command(@_);
417             }
418              
419             sub _goto_label {
420 23     23   51 my $self = shift();
421 23         74 my $label = shift();
422 23         52 my $context = shift();
423 23         47 my $call = shift();
424 23         67 $label =~ s/^://;
425 23         48 $label =~ s/ //g;
426 23 50       90 if ( $context->{'LABEL_INDEX'}{$label} ) {
427 23 100       112 if ( $label =~ /eof/i ) {
428 4         7 my $stack_frame = pop @{ $context->{'STACK'} };
  4         11  
429 4 100       14 if ( defined $stack_frame ) {
430 1         4 $context->{'IP'} = $stack_frame->{'IP'} + 1;
431             } else {
432 3         11 $context->{'IP'} = $context->{'LABEL_INDEX'}{$label};
433             }
434             } else {
435 19 100       76 if ($call) {
436 2         4 push @{ $context->{'STACK'} }, { IP => $context->{'IP'} };
  2         10  
437             }
438 19         67 $context->{'IP'} = $context->{'LABEL_INDEX'}{$label};
439             }
440             } else {
441 0         0 die "Label: $label not indexed. Index contains: " . Dumper( $context->{'LABEL_INDEX'} );
442             }
443             }
444              
445             sub _for_command_evaluation {
446 1     1   3 my $self = shift();
447 1         2 my $comando = shift();
448 1         22 return $self->executor->execute_for_command($comando);
449             }
450              
451             sub _log_line_from_context {
452 133     133   216 my $self = shift();
453 133         187 my $context = shift();
454 133         242 my $line = $context->{'current_line'};
455 133 100 66     512 if ( defined $line && $line ne '' ) {
456 131         2745 $self->linelogger->log_line( $context->{'current_line'} );
457             }
458 133         460 $context->{'current_line'} = '';
459             }
460              
461             1;
462              
463             __END__