File Coverage

blib/lib/MarpaX/Database/Terminfo/String/Grammar/Actions.pm
Criterion Covered Total %
statement 55 231 23.8
branch 26 106 24.5
condition 2 7 28.5
subroutine 15 42 35.7
pod 35 35 100.0
total 133 421 31.5


line stmt bran cond sub pod time code
1 16     16   55 use strict;
  16         20  
  16         370  
2 16     16   49 use warnings FATAL => 'all';
  16         22  
  16         535  
3              
4             package MarpaX::Database::Terminfo::String::Grammar::Actions;
5 16     16   53 use Carp qw/croak/;
  16         21  
  16         650  
6 16     16   55 use Log::Any qw/$log/;
  16         17  
  16         77  
7              
8             # ABSTRACT: Terminfo grammar actions
9              
10             our $VERSION = '0.011'; # VERSION
11              
12              
13              
14             sub new {
15 2     2 1 10358 my $class = shift;
16 2         6 my $self = {_level => 0};
17 2         13 bless($self, $class);
18 2         19 return $self;
19             }
20              
21             sub _doPushLevel {
22 0     0   0 my ($self) = @_;
23              
24 0         0 $self->{_level}++;
25 0         0 return "my \$rc = '';";
26             }
27              
28             sub _doEndLevel {
29 0     0   0 my ($self) = @_;
30              
31 0         0 $self->{_level}--;
32 0         0 return "\$rc;";
33             }
34              
35              
36             sub addEscapedCharacterToRc {
37 2     2 1 1620 my ($self, $c) = @_;
38              
39 2 50       16 if ($log->is_trace) {
40 0         0 $log->tracef('addEscapedCharacterToRc(c="%s")', $c);
41             }
42              
43 2         31 return "\$rc .= " . $self->_escapedCharacter($c) . "; # $c";
44             }
45              
46             sub _escapedCharacter {
47 2     2   4 my ($self, $c) = @_;
48              
49 2 50       7 if ($log->is_trace) {
50 0         0 $log->tracef('_escapedCharacter(c="%s")', $c);
51             }
52              
53 2 100 66     50 if ($c eq '\\E' || $c eq '\\e') { return "\"\\e\""; }
  1 50       6  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
54 0         0 elsif ($c eq '\\a' ) { return "\"\\a\""; }
55 0         0 elsif ($c eq '\\n' ) { return "\"\\n\""; }
56 0         0 elsif ($c eq '\\l' ) { return "\"\\n\""; }
57 0         0 elsif ($c eq '\\r' ) { return "\"\\r\""; }
58 0         0 elsif ($c eq '\\b' ) { return "\"\\b\""; }
59 0         0 elsif ($c eq '\\f' ) { return "\"\\f\""; }
60 0         0 elsif ($c eq '\\t' ) { return "\"\\t\""; }
61 0         0 elsif ($c eq '\\s' ) { return "' '"; }
62 0         0 elsif ($c eq '\\^' ) { return "'^'"; }
63 0         0 elsif ($c eq '\\\\' ) { return "'\\\\'"; }
64 0         0 elsif ($c eq '\\,' ) { return "','"; }
65 0         0 elsif ($c eq '\\:' ) { return "':'"; }
66             # In perl \0 is not the end of a string
67 0         0 elsif ($c eq '\\0' ) { return "\"\\0\""; }
68              
69             elsif (substr($c, 0, 1) eq '^') {
70             #
71             # In perl, control-X is \cX, we support the ASCII C0 set + DEL.
72             # i.e. the range [@A-Z[\]^_?] (c.f. Marpa grammar).
73             # They can ALL be translated litteraly except \c\ that has to be
74             # writen as \c\X in perl. Then we remove the last X.
75             #
76 0         0 my $this = $c;
77 0         0 substr($this, 0, 1, '');
78 0 0       0 if ($this eq '\\') {
79 0         0 return "\"\\c\\X\"; substr(\$rc, -1, 1, '')";
80             } else {
81 0         0 return "\"\\c$this\"";
82             }
83             }
84             elsif (substr($c, 0, 1) eq '\\') {
85             #
86             # Spec says this must be octal digits
87             #
88 1         2 my $oct = $c;
89 1         2 substr($oct, 0, 1, '');
90 1         4 $oct =~ s/^0*//; # Take care... oct(012) == oct(12) = 10 ...
91             # Note: in perl \0 is NOT the end of a string
92 1         6 return "chr(oct($oct))";
93             }
94             else {
95 0         0 croak "Unhandled escape sequence $c\n";
96             }
97             }
98              
99              
100             sub addCharacterToRc {
101 14     14 1 312 my ($self, $c) = @_;
102              
103 14 50       27 if ($log->is_trace) {
104 0         0 $log->tracef('addCharacterToRc(c="%s")', $c);
105             }
106             #
107             # If we quotemeta, then we have to use double quotes
108             #
109 14         84 return "\$rc .= \"" . quotemeta($c) . "\"; # $c";
110             }
111              
112              
113             sub addPercentToRc {
114 0     0 1 0 my ($self, $c) = @_;
115              
116 0 0       0 if ($log->is_trace) {
117 0         0 $log->tracef('addPercentToRc(c="%s")', $c);
118             }
119              
120 0         0 return "\$rc .= '%'; # $c";
121             }
122              
123              
124             sub addPrintPopToRc {
125 2     2 1 41 my ($self, $c) = @_;
126              
127 2 50       5 if ($log->is_trace) {
128 0         0 $log->tracef('addPrintPopToRc(c="%s")', $c);
129             }
130              
131 2         14 return "\$rc .= sprintf('%c', pop(\@iparam)); # $c";
132             }
133              
134              
135             sub addPrintToRc {
136 2     2 1 43 my ($self, $format) = @_;
137              
138 2 50       4 if ($log->is_trace) {
139 0         0 $log->tracef('addPrintToRc(format="%s")', $format);
140             }
141              
142             #
143             # print has the following format:
144             # %[[:]flags][width[.precision]][doxXs]
145             # => we remove the eventual ':' after the '%'
146             # the rest is totally functional within perl
147             #
148 2         12 $format =~ s/^%:/%/;
149              
150 2         7 return "\$rc .= sprintf('$format', pop(\@iparam)); # $format";
151             }
152              
153              
154             sub addPushToRc {
155 4     4 1 96 my ($self, $push) = @_;
156             # %p[1-9]
157              
158 4 50       11 if ($log->is_trace) {
159 0         0 $log->tracef('addpushToRc(push="%s")', $push);
160             }
161              
162 4         25 my $indice = ord(substr($push, -1, 1)) - ord('0') - 1;
163 4         13 return "push(\@iparam, \$param[$indice]); # $push";
164             }
165              
166              
167             sub addDynPop {
168 0     0 1 0 my ($self, $dynpop) = @_;
169             # %P[a-z]
170              
171 0 0       0 if ($log->is_trace) {
172 0         0 $log->tracef('addDynPop(dynpop="%s")', $dynpop);
173             }
174              
175 0         0 my $indice = ord(substr($dynpop, -1, 1)) - ord('a');
176 0         0 return "\$dynamicp->[$indice] = pop(\@iparam); # $dynpop";
177             }
178              
179              
180             sub addDynPush {
181 0     0 1 0 my ($self, $dynpush) = @_;
182             # %g[a-z]
183              
184 0 0       0 if ($log->is_trace) {
185 0         0 $log->tracef('addDynPush(dynpush="%s")', $dynpush);
186             }
187              
188 0         0 my $indice = ord(substr($dynpush, -1, 1)) - ord('a');
189 0         0 return "push(\@iparam, \$dynamicp->[$indice]); # $dynpush";
190             }
191              
192              
193             sub addStaticPop {
194 0     0 1 0 my ($self, $staticpop) = @_;
195             # %P[A-Z]
196              
197 0 0       0 if ($log->is_trace) {
198 0         0 $log->tracef('addStaticPop(staticpop="%s")', $staticpop);
199             }
200              
201 0         0 my $indice = ord(substr($staticpop, -1, 1)) - ord('A');
202 0         0 return "\$staticp->[$indice] = pop(\@iparam); # $staticpop";
203             }
204              
205              
206             sub addStaticPush {
207 0     0 1 0 my ($self, $staticpush) = @_;
208             # %g[A-Z]
209              
210 0 0       0 if ($log->is_trace) {
211 0         0 $log->tracef('addStaticPush(staticpush="%s")', $staticpush);
212             }
213              
214 0         0 my $indice = ord(substr($staticpush, -1, 1)) - ord('A');
215 0         0 return "push(\@iparam, \$staticp->[$indice]); # $staticpush";
216             }
217              
218              
219             sub addL {
220 0     0 1 0 my ($self, $l) = @_;
221             # %l
222              
223 0 0       0 if ($log->is_trace) {
224 0         0 $log->tracef('addL(l="%s")', $l);
225             }
226              
227 0         0 return "push(\@iparam, strlen(pop(\@iparam)); # $l";
228             }
229              
230              
231             sub addPushConst {
232 0     0 1 0 my ($self, $const) = @_;
233             # %'c'
234              
235 0 0       0 if ($log->is_trace) {
236 0         0 $log->tracef('addPushConst(const="%s")', $const);
237             }
238              
239             #
240             # Either this is an escaped number \ddd, or anything but a quote
241             #
242 0         0 my $inside = $const;
243 0         0 substr($inside, 0, 2, ''); # Remove %' at the beginning
244 0         0 substr($inside, -1, 1, ''); # Remove ' at the end
245              
246 0 0       0 if (substr($inside, 0, 1) eq '\\') {
247 0         0 return "push(\@iparam, " . $self->_escapedCharacter($inside) . "); # $const";
248             } else {
249 0         0 return "push(\@iparam, \"" . quotemeta($inside) . "\"); # $const";
250             }
251             }
252              
253              
254             sub addPushInt {
255 2     2 1 44 my ($self, $int) = @_;
256             # %{nn}
257              
258 2 50       5 if ($log->is_trace) {
259 0         0 $log->tracef('addPushInt(int="%s")', $int);
260             }
261              
262 2         11 my $value = $int;
263 2         3 substr($value, 0, 2, '');
264 2         3 substr($value, -1, 1, '');
265              
266 2         5 return "push(\@iparam, $value); # $int";
267             }
268              
269              
270             sub addPlus {
271 0     0 1 0 my ($self, $plus) = @_;
272             # %+
273              
274 0 0       0 if ($log->is_trace) {
275 0         0 $log->tracef('addPlus(plus="%s")', $plus);
276             }
277              
278 0         0 return "push(\@iparam, pop(\@iparam) + pop(\@iparam)); # $plus";
279             }
280              
281              
282             sub addMinus {
283 0     0 1 0 my ($self, $minus) = @_;
284             # %+
285              
286 0 0       0 if ($log->is_trace) {
287 0         0 $log->tracef('addMinus(minus="%s")', $minus);
288             }
289              
290 0         0 return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x - \$y); } # $minus";
291             }
292              
293              
294             sub addStar {
295 0     0 1 0 my ($self, $star) = @_;
296             # %+
297              
298 0 0       0 if ($log->is_trace) {
299 0         0 $log->tracef('addStar(star="%s")', $star);
300             }
301              
302 0         0 return "push(\@iparam, pop(\@iparam) * pop(\@iparam)); # $star";
303             }
304              
305              
306             sub addDiv {
307 0     0 1 0 my ($self, $div) = @_;
308             # %+
309              
310 0 0       0 if ($log->is_trace) {
311 0         0 $log->tracef('addDiv(div="%s")', $div);
312             }
313              
314 0         0 return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$y ? int(\$x / \$y) : 0); } # $div";
315             }
316              
317              
318             sub addMod {
319 0     0 1 0 my ($self, $mod) = @_;
320             # %+
321              
322 0 0       0 if ($log->is_trace) {
323 0         0 $log->tracef('addMod(mod="%s")', $mod);
324             }
325              
326 0         0 return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$y ? int(\$x % \$y) : 0); } # $mod";
327             }
328              
329              
330             sub addBitAnd {
331 0     0 1 0 my ($self, $bitAnd) = @_;
332             # %&
333              
334 0 0       0 if ($log->is_trace) {
335 0         0 $log->tracef('addBitAnd(bitAnd="%s")', $bitAnd);
336             }
337              
338 0         0 return "push(\@iparam, pop(\@iparam) & pop(\@iparam)); # $bitAnd";
339             }
340              
341              
342             sub addBitOr {
343 0     0 1 0 my ($self, $bitOr) = @_;
344             # %|
345              
346 0 0       0 if ($log->is_trace) {
347 0         0 $log->tracef('addBitOr(bitOr="%s")', $bitOr);
348             }
349              
350 0         0 return "push(\@iparam, pop(\@iparam) | pop(\@iparam)); # $bitOr";
351             }
352              
353              
354             sub addBitXor {
355 2     2 1 43 my ($self, $bitXor) = @_;
356             # %^
357              
358 2 50       5 if ($log->is_trace) {
359 0         0 $log->tracef('addBitXor(bitXor="%s")', $bitXor);
360             }
361              
362 2         13 return "push(\@iparam, pop(\@iparam) ^ pop(\@iparam)); # $bitXor";
363             }
364              
365              
366             sub addEqual {
367 0     0 1 0 my ($self, $equal) = @_;
368             # %=
369              
370 0 0       0 if ($log->is_trace) {
371 0         0 $log->tracef('addEqual(equal="%s")', $equal);
372             }
373              
374 0         0 return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x == \$y); } # $equal";
375             }
376              
377              
378             sub addGreater {
379 0     0 1 0 my ($self, $greater) = @_;
380             # %>
381              
382 0 0       0 if ($log->is_trace) {
383 0         0 $log->tracef('addGreater(greater="%s")', $greater);
384             }
385              
386 0         0 return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x > \$y); } # $greater";
387             }
388              
389              
390             sub addLower {
391 0     0 1 0 my ($self, $lower) = @_;
392             # %<
393              
394 0 0       0 if ($log->is_trace) {
395 0         0 $log->tracef('addLower(lower="%s")', $lower);
396             }
397              
398 0         0 return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x < \$y); } # $lower";
399             }
400              
401              
402             sub addLogicalAnd {
403 0     0 1 0 my ($self, $logicalAnd) = @_;
404             # %A
405              
406 0 0       0 if ($log->is_trace) {
407 0         0 $log->tracef('addLogicalAnd(logicalAnd="%s")', $logicalAnd);
408             }
409              
410 0         0 return "push(\@iparam, pop(\@iparam) && pop(\@iparam)); # $logicalAnd";
411             }
412              
413              
414             sub addLogicalOr {
415 0     0 1 0 my ($self, $logicalOr) = @_;
416             # %O
417              
418 0 0       0 if ($log->is_trace) {
419 0         0 $log->tracef('addLogicalOr(logicalOr="%s")', $logicalOr);
420             }
421              
422 0         0 return "push(\@iparam, pop(\@iparam) || pop(\@iparam)); # $logicalOr";
423             }
424              
425              
426             sub addNot {
427 0     0 1 0 my ($self, $not) = @_;
428             # %!
429              
430 0 0       0 if ($log->is_trace) {
431 0         0 $log->tracef('addNot(not="%s")', $not);
432             }
433              
434 0         0 return "push(\@iparam, ! pop(\@iparam)); # $not";
435             }
436              
437              
438             sub addComplement {
439 0     0 1 0 my ($self, $complement) = @_;
440             # %!
441              
442 0 0       0 if ($log->is_trace) {
443 0         0 $log->tracef('addComplement(complement="%s")', $complement);
444             }
445              
446 0         0 return "push(\@iparam, ~ pop(\@iparam)); # $complement";
447             }
448              
449              
450             sub addOneToParams {
451 1     1 1 24 my ($self, $one) = @_;
452             # %i
453              
454 1 50       3 if ($log->is_trace) {
455 0         0 $log->tracef('addOneToParams(one="%s")', $one);
456             }
457              
458 1         22 return "map {\$param[\$_]++} (0..\$#param); # $one";
459             }
460              
461              
462             sub addIfThenElse {
463 0     0 1 0 my ($self, $if, $units1p, $then, $units2p, $elsifUnitsp, $else, $units3p, $endif) = @_;
464              
465 0 0       0 if ($log->is_trace) {
466 0         0 $log->tracef('addIfThenElse($if="%s", $units1p="%s", $then="%s", $units2p="%s", $elsifUnitsp="%s", $else="%s", $units3p="%s", $endif="%s")', $if, $units1p, $then, $units2p, $elsifUnitsp, $else, $units3p, $endif);
467             }
468              
469 0         0 my $units1 = join("\n", @{$units1p});
  0         0  
470 0         0 my $units2 = join("\n", @{$units2p});
  0         0  
471 0         0 my $elsifUnits = join("\n", @{$elsifUnitsp});
  0         0  
472 0         0 my $units3 = join("\n", @{$units3p});
  0         0  
473             #
474             # We increase indentation of units
475             #
476 0         0 $units1 =~ s/^/ /smg;
477 0         0 $units2 =~ s/^/ /smg;
478 0         0 $units3 =~ s/^/ /smg;
479             #
480             # $endif can be the EOF
481             #
482 0   0     0 $endif ||= 'implicit by eof';
483              
484 0         0 my $rc = "if (do { # $if
485             $units1
486             pop(\@iparam);
487             }) { # $then
488             $units2
489             }";
490 0 0       0 if ($elsifUnits) {
491 0         0 $rc .= "\n$elsifUnits";
492             }
493 0         0 $rc .= "
494             else { # $else
495             $units3
496             } # $endif";
497              
498 0         0 return $rc;
499             }
500              
501              
502             sub addIfThen {
503 0     0 1 0 my ($self, $if, $units1p, $then, $units2p, $elsifUnitsp, $endif) = @_;
504              
505 0 0       0 if ($log->is_trace) {
506 0         0 $log->tracef('addIfThen($if="%s", $units1p="%s", $then="%s", $units2p="%s", $elsifUnitsp="%s", $endif="%s")', $if, $units1p, $then, $units2p, $elsifUnitsp, $endif);
507             }
508              
509 0         0 my $units1 = join("\n", @{$units1p});
  0         0  
510 0         0 my $units2 = join("\n", @{$units2p});
  0         0  
511 0         0 my $elsifUnits = join("\n", @{$elsifUnitsp});
  0         0  
512             #
513             # We increase indentation of units
514             #
515 0         0 $units1 =~ s/^/ /smg;
516 0         0 $units2 =~ s/^/ /smg;
517             #
518             # $endif can be the EOF
519             #
520 0   0     0 $endif ||= 'implicit by eof';
521              
522 0         0 my $rc = "if (do { # $if
523             $units1
524             pop(\@iparam);
525             }) { # $then
526             $units2
527             } # $endif";
528 0 0       0 if ($elsifUnits) {
529 0         0 $rc .= "\n$elsifUnits";
530             }
531              
532 0         0 return $rc;
533             }
534              
535              
536             sub elifUnit {
537 0     0 1 0 my ($self, $else, $units1p, $then, $units2p) = @_;
538              
539 0 0       0 if ($log->is_trace) {
540 0         0 $log->tracef('elifUnit($else="%s", $units1p="%s", $then="%s", $units2p="%s")', $else, $units1p, $then, $units2p);
541             }
542 0         0 my $units1 = join("\n", @{$units1p});
  0         0  
543 0         0 my $units2 = join("\n", @{$units2p});
  0         0  
544             #
545             # We increase indentation of units
546             #
547 0         0 $units1 =~ s/^/ /smg;
548 0         0 $units2 =~ s/^/ /smg;
549              
550 0         0 my $rc = "elsif (do { # $else
551             $units1
552             pop(\@iparam);
553             }) { # $then
554             $units2
555             }";
556              
557 0         0 return $rc;
558             }
559              
560              
561             sub eof {
562 2     2 1 50 my ($self, @args) = @_;
563              
564 2         7 return '';
565             }
566              
567              
568             sub ifEndif {
569 0     0 1   my ($self, @args) = @_;
570              
571 0           return '# IF/ENDIF ignored';
572             }
573              
574             1;
575              
576             __END__