File Coverage

blib/lib/MarpaX/Languages/M4/Impl/Default.pm
Criterion Covered Total %
statement 3208 4067 78.8
branch 960 2242 42.8
condition 117 257 45.5
subroutine 363 432 84.0
pod n/a
total 4648 6998 66.4


line stmt bran cond sub pod time code
1 1     1   6 use Moops;
  1         2  
  1         5  
2 1     1   1821 use MarpaX::Languages::M4::Impl::Parser;
  1         4  
  1         17  
3              
4             # PODNAME: MarpaX::Languages::M4::Impl::Default
5              
6             # ABSTRACT: M4 pre-processor - default implementation
7              
8             #
9             # General note: having API'sed M4 introduce a difficulty when dealing
10             # with diversions: M4 is primilarly designed to act as a command-line
11             # and thus have a clear distinction between its internal buffer that is
12             # constantly being rewriten, and the stdout.
13             # But in the API version, undiverting number 0 (i.e. stdout) should go
14             # to the internal buffer, /without/ rescanning what has been undiverted.
15             #
16             # Therefore the position in variable output can be changed by undiverting number 0
17             # without rescanning.
18             #
19             # This is achieved in the parser implementation, that is maintaining itself
20             # the next position for scanning.
21             #
22             #
23             # Note: GNU-like extension but with different semantics:
24             # ------------------------------------------------------
25             # format Perl sprintf implementation
26             # incr C.f. policy_integer_type, defaults to a 32 bits integer. "native" policy uses int, like GNU.
27             # decr C.f. policy_integer_type, defaults to a 32 bits integer. "native" policy uses int, like GNU.
28             #
29             # Ah... if you wonder why there is (?#) when I do ar// on a variable, this is because,
30             # a per perldoc perlop:
31             #
32             # The empty pattern //
33             # If the PATTERN evaluates to the empty string, the last successfully matched regular expression is used
34             # instead. In this case, only the "g" and "c" flags on the empty pattern is honoured - the other flags are
35             # taken from the original pattern. If no match has previously succeeded, this will (silently) act instead
36             # as a genuine empty pattern (which will always match).
37             #
38              
39 1     1   2029 class MarpaX::Languages::M4::Impl::Default {
  1     1   27  
  1         9  
  1         2  
  1         69  
  1         6  
  1         3  
  1         8  
  1         351  
  1         2  
  1         7  
  1         65  
  1         2  
  1         47  
  1         5  
  1         1  
  1         82  
  1         40  
  1         10  
  1         4  
  1         14  
  1         4776  
  1         2  
  1         8  
  1         474  
  1         2  
  1         9  
  1         144  
  1         2  
  1         9  
  1         80  
  1         2  
  1         14  
  1         209  
  1         2  
  1         9  
  1         890  
  1         2  
  1         9  
  1         2004  
  1         3  
  1         5  
  1         2  
  1         20  
  1         4  
  1         2  
  1         43  
  1         5  
  1         2  
  1         137  
  1         12068  
40 1         16 extends 'MarpaX::Languages::M4::Impl::Parser';
41              
42 1         204 our $VERSION = '0.019'; # VERSION
43              
44 1         3 our $AUTHORITY = 'cpan:JDDPAUSE'; # AUTHORITY
45              
46 1     1   426 use Bit::Vector;
  1         807  
  1         78  
47 1     1   267 use Encode::Locale;
  1         2828  
  1         45  
48 1     1   7 use Encode;
  1         2  
  1         80  
49 1     1   290 use Env::Path qw/M4PATH/;
  1         2337  
  1         7  
50 1     1   121 use Errno;
  1         2  
  1         40  
51 1     1   6 use File::Find;
  1         2  
  1         73  
52 1     1   10 use File::Spec;
  1         4  
  1         15  
53 1     1   31 use File::Temp;
  1         2  
  1         75  
54 1     1   259 use IO::CaptureOutput qw/capture_exec/;
  1         1819  
  1         53  
55 1     1   7 use IO::Handle;
  1         2  
  1         35  
56 1     1   254 use IO::File;
  1         872  
  1         156  
57 1     1   237 use IO::Interactive qw/is_interactive/;
  1         824  
  1         5  
58 1     1   313 use IO::Scalar;
  1         3542  
  1         46  
59 1     1   381 use MarpaX::Languages::M4::Impl::Default::BaseConversion;
  1         3  
  1         10  
60 1     1   447 use MarpaX::Languages::M4::Impl::Default::Eval;
  1         6  
  1         21  
61 1     1   496 use MarpaX::Languages::M4::Impl::Macros;
  1         4  
  1         8  
62 1     1   399 use MarpaX::Languages::M4::Impl::Macro;
  1         5  
  1         10  
63 1     1   471 use MarpaX::Languages::M4::Impl::Regexp;
  1         4  
  1         10  
64 1     1   449 use MarpaX::Languages::M4::Role::Impl;
  1         6  
  1         12  
65 1     1   76 use MarpaX::Languages::M4::Type::Macro -all;
  1         2  
  1         10  
66 1     1   1453 use MarpaX::Languages::M4::Type::Impl -all;
  1         4  
  1         13  
67 1     1   846 use MarpaX::Languages::M4::Type::Regexp -all;
  1         2  
  1         8  
68 1     1   1812 use MarpaX::Languages::M4::Type::Token -all;
  1         4  
  1         15  
69 1     1   866 use Marpa::R2;
  1         4  
  1         10  
70 1     1   26 use MooX::HandlesVia;
  1         2  
  1         9  
71 1     1   138 use Scalar::Util qw/blessed/;
  1         3  
  1         71  
72 1     1   317 use Throwable::Factory ImplException => undef;
  1         37680  
  1         7  
73 1     1   2969 use MooX::Options protect_argv => 0, flavour => [qw/require_order/];
  1         1815  
  1         7  
74 1     1   57917 use MooX::Role::Logger;
  1         2542  
  1         17  
75 1     1   65 use POSIX qw/EXIT_SUCCESS EXIT_FAILURE/;
  1         2  
  1         11  
76 1     1   965 use Perl::OSType ':all';
  1         410  
  1         163  
77 1     1   9 use Types::Common::Numeric -all;
  1         2  
  1         11  
78              
79             # -----------------------------------------------------------------
80             # The list of GNU-like extensions is known in advanced and is fixed
81             # -----------------------------------------------------------------
82 1         13 our %Default_EXTENSIONS = (
83              
84             # __file__ => 1, # TO DO
85             # __line__ => 1, # TO DO
86             __program__ => 1,
87             builtin => 1,
88             changeword => 1,
89             debugmode => 1,
90             debugfile => 1,
91             esyscmd => 1,
92             format => 1,
93             indir => 1,
94             patsubst => 1,
95             regexp => 1,
96             __gnu__ => 1,
97             __os2__ => 1,
98             os2 => 1,
99             __unix__ => 1,
100             unix => 1,
101             __windows__ => 1,
102             windows => 1,
103             );
104              
105             #
106             # Comments are recognized in preference to macros.
107             # Comments are recognized in preference to argument collection.
108             # Macros are recognized in preference to the begin-quote string.
109             # Quotes are recognized in preference to argument collection.
110             #
111              
112             #
113             # Eval: constants for radix and the grammar
114             #
115 1         13 our @nums = ( 0 .. 9, 'a' .. 'z', 'A' .. 'Z' );
116 1         4 our %nums = map { $nums[$_] => $_ } 0 .. $#nums;
  62         123  
117 1         18 our $EVAL_G = Marpa::R2::Scanless::G->new(
118             { source => \<<EVAL_GRAMMAR
119             :default ::= action => ::first
120             :start ::= eval
121             eval ::= Expression action => _eval
122              
123             Expression ::=
124             Number
125             | ('(') Expression (')') assoc => group
126             # Catch common invalid operations for a nice error message
127             # Uncatched stuff will have the Marpa native exception.
128             || '++' (Expression) action => _invalidOp
129             | (Expression) '+=' (Expression) action => _invalidOp
130             | (Expression) '--' (Expression) action => _invalidOp
131             | (Expression) '-=' (Expression) action => _invalidOp
132             | (Expression) '*=' (Expression) action => _invalidOp
133             | (Expression) '/=' (Expression) action => _invalidOp
134             | (Expression) '%=' (Expression) action => _invalidOp
135             | (Expression) '>>=' (Expression) action => _invalidOp
136             | (Expression) '<<=' (Expression) action => _invalidOp
137             | (Expression) '^=' (Expression) action => _invalidOp
138             | (Expression) '&=' (Expression) action => _invalidOp
139             | (Expression) '|=' (Expression) action => _invalidOp
140             || '+' Expression action => _noop
141             | '-' Expression action => _neg
142             | '~' Expression action => _bneg
143             | '!' Expression action => _lneg
144             || Expression '**' Expression assoc => right action => _exp
145             || Expression '*' Expression action => _mul
146             | Expression '/' Expression action => _div
147             | Expression '%' Expression action => _mod
148             || Expression '+' Expression action => _add
149             | Expression '-' Expression action => _sub
150             || Expression '<<' Expression action => _left
151             | Expression '>>' Expression action => _right
152             || Expression '>' Expression action => _gt
153             | Expression '>=' Expression action => _ge
154             | Expression '<' Expression action => _lt
155             | Expression '<=' Expression action => _le
156             || Expression '==' Expression action => _eq
157             # Special case of '=' aliased to '=='
158             | Expression '=' Expression action => _eq2
159             | Expression '!=' Expression action => _ne
160             || Expression '&' Expression action => _band
161             || Expression '^' Expression action => _bxor
162             || Expression '|' Expression action => _bor
163             || Expression '&&' Expression action => _land
164             || Expression '||' Expression action => _lor
165              
166             Number ::= decimalNumber action => _decimal
167             | octalNumber action => _octal
168             | hexaNumber action => _hex
169             | binaryNumber action => _binary
170             | radixNumber action => _radix
171              
172             _DECDIGITS ~ [0-9]+
173             _OCTDIGITS ~ [0-7]+
174             _HEXDIGITS ~ [0-9a-fA-F]+
175             _BINDIGITS ~ [0-1]+
176             _RADIXDIGITS ~ [0-9a-zA-Z]+
177             _RADIX ~ '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
178             | '10' | '11' | '12' | '13' | '14' | '15' | '16' | '17' | '18' | '19'
179             | '20' | '21' | '22' | '23' | '24' | '25' | '26' | '27' | '28' | '29'
180             | '30' | '31' | '32' | '33' | '34' | '35' | '36'
181              
182             decimalNumber ~ _DECDIGITS
183             :lexeme ~ <octalNumber> priority => 1 # An octal number is ambiguous v.s. decimal, and wins
184             octalNumber ~ '0' _OCTDIGITS
185             hexaNumber ~ '0x' _HEXDIGITS
186             binaryNumber ~ '0b' _BINDIGITS
187             radixNumber ~ '0r' _RADIX ':' _RADIXDIGITS
188              
189             _WS_many ~ [\\s]+
190             :discard ~ _WS_many
191             EVAL_GRAMMAR
192             }
193             );
194              
195             # ------------------------
196             # PROCESS OPTIONS IN ORDER
197             # ------------------------
198 1 50   1   8958 around new_with_options {
  1 50   140   5  
  1         598  
  1         179614  
  140         407204  
  140         661  
  140         506  
  140         341  
199             #
200             # $self is in reality a $class
201             #
202 140         282 my $class = $self;
203 140         819 $self = $class->${^NEXT}(@_);
204             #
205             # Because this is done before caller got the returned value:
206             # in the logger callback he gan get the $self value using
207             # this localized variable
208             #
209 140         7814 local $MarpaX::Languages::M4::SELF = $self;
210 140         733 while (@ARGV) {
211             #
212             # Process this non-option
213             #
214 0         0 my $file = shift(@ARGV);
215 0 0       0 if ( Undef->check($file) ) {
216 0         0 next;
217             }
218 0         0 $self->impl_parseIncrementalFile($file);
219             #
220             # Merge next option values
221             #
222 0         0 my %nextOpts = $class->parse_options();
223 0         0 foreach ( keys %nextOpts ) {
224             #
225             # Look to options. I made sure all ArrayRef options
226             # have an 'elements' handle named: xxx_elements.
227             #
228 0 0       0 if ( ArrayRef->check( $nextOpts{$_} ) ) {
229 0         0 my $elementsMethod = $_ . '_elements';
230             $self->$_(
231 0         0 [ $self->$elementsMethod, @{ $nextOpts{$_} } ] );
  0         0  
232             }
233             else {
234 0         0 $self->$_( $nextOpts{$_} );
235             }
236             }
237             }
238 140         914 return $self;
239             }
240              
241             # ---------------------------------------------------------------
242             # OPTIONS
243             # ---------------------------------------------------------------
244             # * Options always have triggers
245             # * If an option xxx maps to an internal attribute _xxx,
246             # this attribute is always rwp + lazy + builder
247             #
248             # Exception are:
249             # --reload-state: option have order 0 to be seen first, but it is processed explicitely
250             # only before options D, U and t.
251             # --freeze-state: it is implemented at end-of-input
252             # ---------------------------------------------------------------
253              
254             # =========================
255             # --reload-state
256             # =========================
257 1         991 option reload_state => (
258             is => 'rw',
259             isa => Str,
260             trigger => 1,
261             format => 's',
262             short => 'R',
263             doc =>
264             q{Before execution starts, recover the internal state from the specified frozen file. The options -D, -U, and -t take effect after state is reloaded, but before the input files are read. This option is always processed first. GNU autoconf likes to check the help searching for reload-state... So here it is -;}
265             );
266              
267 1         2397 has _stateReloaded => ( is => 'rwp', isa => Bool, default => false );
268              
269 1 0   1   3468 method _trigger_reload_state (Str $reloadState, @rest --> Undef) {
  1 0   0   4  
  1 0       168  
  1 0       7  
  1 0       3  
  1 0       222  
  1         1422  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
270 0         0 $self->impl_reloadState;
271 0         0 return;
272             }
273              
274             # =========================
275             # --freeze-state
276             # =========================
277 1         2657 option freeze_state => (
278             is => 'rw',
279             isa => Str,
280             default => '',
281             format => 's',
282             short => 'F',
283             doc =>
284             q{Once execution is finished, write out the frozen state on the specified file. It is conventional, but not required, for file to end in ‘.m4f’. This is implemented at object destruction and is executed once.}
285             );
286              
287 1         1511 has _stateFreezed => ( is => 'rwp', isa => Bool, default => false );
288              
289             # =========================
290             # --cmdtounix
291             # =========================
292 1         1592 option cmdtounix => (
293             is => 'rw',
294             isa => Bool,
295             negativable => 1,
296             trigger => 1,
297             doc =>
298             q{Convert any command output from platform's native end-of-line character set to Unix style (LF). Default to a false value. Option is negativable with '--no-' prefix.}
299             );
300 1         1622 has _cmdtounix => ( is => 'rwp', isa => Bool, lazy => 1, builder => 1 );
301              
302 1 50   1   3002 method _trigger_cmdtounix (Bool $cmdtounix, @rest --> Undef) {
  1 50   140   3  
  1 50       133  
  1 50       6  
  1 50       2  
  1 50       113  
  1         2250  
  140         13038  
  140         633  
  140         569  
  140         520  
  140         295  
  140         716  
  140         622  
  140         258  
303 140         2880 $self->_set__cmdtounix($cmdtounix);
304 140         4560 return;
305             }
306              
307 1 0   1   1201 method _build__cmdtounix {false}
  1     0   3  
  1         125  
  1         2767  
  0         0  
  0         0  
  0         0  
308              
309             # =======================================
310             # --changeword-is-character-per-character
311             # =======================================
312 1         208 option changeword_is_character_per_character => (
313             is => 'rw',
314             isa => Bool,
315             negativable => 1,
316             trigger => 1,
317             doc =>
318             q{Default behaviour is to construct a word character at a time. I.e. is a regular expression accepts 'foo', it must also accept 'f' and 'fo'. This flag can disable such behaviour. Default to a true value. Option is negativable with '--no-' prefix.}
319             );
320 1         1677 has _changeword_is_character_per_character =>
321             ( is => 'rwp', isa => Bool, lazy => 1, builder => 1 );
322              
323 1 50   1   4069 method _trigger_changeword_is_character_per_character (Bool $changeword_is_character_per_character, @rest --> Undef) {
  1 50   2   3  
  1 50       244  
  1 50       12  
  1 50       4  
  1 50       171  
  1         2468  
  2         185  
  2         9  
  2         8  
  2         12  
  2         4  
  2         10  
  2         7  
  2         3  
324 2         42 $self->_set__changeword_is_character_per_character(
325             $changeword_is_character_per_character);
326 2         110 return;
327             }
328              
329 1 50   1   1356 method _build__changeword_is_character_per_character {true}
  1     136   2  
  1         120  
  1         2461  
  136         1873  
  136         237  
  136         480  
330              
331             # =========================
332             # --inctounix
333             # =========================
334 1         165 option inctounix => (
335             is => 'rw',
336             isa => Bool,
337             negativable => 1,
338             trigger => 1,
339             doc =>
340             q{Convert any input (M4's include, stdin, file) from platform's native end-of-line character set to Unix style (LF). Default to a false value. Option is negativable with '--no-' prefix.}
341             );
342 1         1477 has _inctounix => ( is => 'rwp', isa => Bool, lazy => 1, builder => 1 );
343              
344 1 50   1   3365 method _trigger_inctounix (Bool $inctounix, @rest --> Undef) {
  1 50   140   3  
  1 50       188  
  1 50       9  
  1 50       4  
  1 50       210  
  1         2079  
  140         13222  
  140         515  
  140         661  
  140         533  
  140         298  
  140         600  
  140         552  
  140         228  
345 140         2972 $self->_set__inctounix($inctounix);
346 140         4349 return;
347             }
348              
349 1 0   1   1367 method _build__inctounix {false}
  1     0   2  
  1         349  
  1         2364  
  0         0  
  0         0  
  0         0  
350              
351             # =========================
352             # --tokens-priority
353             # =========================
354 1         159 our $DEFAULT_TOKENS_PRIORITY = [qw/COMMENT WORD QUOTEDSTRING CHARACTER/];
355             option tokens_priority => (
356             is => 'rw',
357             isa => ArrayRef [Str],
358             format => 's@',
359             autosplit => ',',
360             trigger => 1,
361             handles_via => 'Array',
362             handles => { tokens_priority_elements => 'elements' },
363 140         6542 default => sub { return $DEFAULT_TOKENS_PRIORITY },
364             doc =>
365             "Tokens priority. If setted, it is highly recommended to list all allowed values, that are : \"WORD\", \"MACRO\", \"QUOTEDSTRING\", and \"COMMENT\". The order of appearance on the command-line will be the prefered order when parsing M4 input. Multiple values can be given in the same switch if separated by the comma character ','. Unlisted values will keep their relative order from the default, which is: "
366             . join( ',',
367 1         7 @{$DEFAULT_TOKENS_PRIORITY}
  1         141  
368             . ". Please note that when doing arguments collection, the parser forces unquoted parenthesis and comma to have higher priority to quoted strings and comments."
369             )
370             );
371 1         2993 has _tokens_priority => (
372             is => 'rwp',
373             lazy => 1,
374             builder => 1,
375             isa => ArrayRef [M4Token],
376             handles_via => 'Array',
377             handles => {
378             _tokens_priority_elements => 'elements',
379             _tokens_priority_count => 'count',
380             _tokens_priority_get => 'get'
381             },
382             );
383              
384 1 0   1   5101 method _trigger_tokens_priority (ArrayRef[Str] $tokens_priority, @rest --> Undef) {
  1 0   0   2  
  1 0       210  
  1 0       6  
  1 0       2  
  1 0       331  
  1         5782  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
385 0         0 my %tokens_priority = ();
386 0         0 my $currentMaxIndex = $#{$tokens_priority};
  0         0  
387 0         0 foreach ( 0 .. $currentMaxIndex ) {
388 0         0 $tokens_priority{ $tokens_priority->[$_] } = $_;
389             }
390 0         0 foreach ( 0 .. $self->_tokens_priority_count - 1 ) {
391 0         0 my $lexeme = $self->_tokens_priority_get($_);
392 0 0       0 if ( !exists( $tokens_priority{$lexeme} ) ) {
393 0         0 $tokens_priority{$lexeme} = ++$currentMaxIndex;
394             }
395             }
396              
397             $self->_set__tokens_priority(
398 0         0 [ sort { $tokens_priority{$a} <=> $tokens_priority{$b} }
  0         0  
399             keys %tokens_priority
400             ]
401             );
402 0         0 return;
403             }
404              
405 1 50   1   1219 method _build__tokens_priority {$DEFAULT_TOKENS_PRIORITY}
  1     139   2  
  1         140  
  1         2554  
  139         4349  
  139         312  
  139         2112  
406              
407             # =========================
408             # --integer-type
409             # =========================
410 1         164 option integer_type => (
411             is => 'rw',
412             isa => Str,
413             trigger => 1,
414             format => 's',
415             doc =>
416             q{Integer type. Possible values: "native" (will use what your hardware provides using the libc with which perl was built), "bitvector" (will use s/w-driven bit-per-bit manipulations; this is the only portable option value). Default: "bitvector".}
417             );
418 1         1810 has _integer_type => (
419             is => 'rwp',
420             lazy => 1,
421             builder => 1,
422             isa => Enum [qw/native bitvector/]
423             );
424              
425 1 0   1   3207 method _trigger_integer_type (Str $integer_type, @rest --> Undef) {
  1 0   0   4  
  1 0       158  
  1 0       7  
  1 0       2  
  1 0       110  
  1         2942  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
426 0         0 $self->_set__integer_type($integer_type);
427 0         0 return;
428             }
429              
430 1 50   1   1114 method _build__integer_type {'bitvector'}
  1     11   2  
  1         141  
  1         2505  
  11         168  
  11         27  
  11         187  
431              
432             # =========================
433             # --regexp-type
434             # =========================
435 1         241 option regexp_type => (
436             is => 'rw',
437             isa => Str,
438             trigger => 1,
439             format => 's',
440             doc =>
441             q{Regular expression engine. Affect the syntax of regexp! Possible values: "GNU", "perl". Default: "GNU" (i.e. the GNU M4 default engine). Please note that this has NO effect on the eventual replacement string, that follows striclty GNU convention, i.e. only \\0 (deprecated), \\& and \\1 to \\9 are supported.}
442             );
443 1         1713 has _regexp_type => (
444             is => 'rwp',
445             lazy => 1,
446             builder => 1,
447             isa => M4RegexpType
448             );
449              
450 1 50   1   3277 method _trigger_regexp_type (Str $regexp_type, @rest --> Undef) {
  1 50   7   2  
  1 50       152  
  1 50       6  
  1 50       2  
  1 50       145  
  1         2044  
  7         749  
  7         38  
  7         37  
  7         38  
  7         15  
  7         36  
  7         34  
  7         18  
451 7         160 $self->_set__regexp_type($regexp_type);
452 7         335 return;
453             }
454              
455 1 50   1   1161 method _build__regexp_type {'GNU'}
  1     13   3  
  1         149  
  1         2275  
  13         218  
  13         37  
  13         241  
456              
457             # =========================
458             # --integer-bits
459             # =========================
460 1         161 our $INTEGER_BITS_DEFAULT_VALUE = 32;
461 1         6 option integer_bits => (
462             is => 'rw',
463             isa => PositiveInt,
464             trigger => 1,
465             format => 'i',
466             doc =>
467             "Number of bits for integer arithmetic. Possible values: any positive integer. Meaningful for builtins incr and decr only when policy_integer_type is \"bitvector\", always meaningful for builtin eval. Default: $INTEGER_BITS_DEFAULT_VALUE."
468             );
469              
470 1         1479 has _integer_bits => (
471             is => 'rwp',
472             lazy => 1,
473             builder => 1,
474             isa => PositiveInt,
475             );
476              
477 1 0   1   3079 method _trigger_integer_bits (Str $integer_bits, @rest --> Undef) {
  1 0   0   2  
  1 0       173  
  1 0       6  
  1 0       3  
  1 0       111  
  1         1743  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
478 0         0 $self->_set__integer_bits($integer_bits);
479 0         0 return;
480             }
481              
482 1 50   1   1093 method _build__integer_bits {$INTEGER_BITS_DEFAULT_VALUE}
  1     18   7  
  1         200  
  1         2395  
  18         289  
  18         42  
  18         353  
483              
484             # =========================
485             # --m4wrap-order
486             # =========================
487 1         190 option m4wrap_order => (
488             is => 'rw',
489             isa => Str,
490             trigger => 1,
491             format => 's',
492             doc =>
493             q{M4wrap unbuffer mode. Possible values: "LIFO" (Last In, First Out), "FIFO" (First In, First Out). Default: "LIFO".}
494             );
495              
496 1         1537 has _m4wrap_order => (
497             is => 'rwp',
498             lazy => 1,
499             builder => 1,
500             isa => Enum [qw/LIFO FIFO/]
501             );
502              
503 1 0   1   3121 method _trigger_m4wrap_order (Str $m4wrap_order, @rest --> Undef) {
  1 0   0   2  
  1 0       141  
  1 0       6  
  1 0       3  
  1 0       112  
  1         2759  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
504 0         0 $self->_set__m4wrap_order($m4wrap_order);
505 0         0 return;
506             }
507              
508 1 50   1   1085 method _build__m4wrap_order {'LIFO'}
  1     8   3  
  1         129  
  1         2392  
  8         121  
  8         17  
  8         128  
509              
510             # =========================
511             # --divert-type
512             # =========================
513 1         166 option divert_type => (
514             is => 'rw',
515             trigger => 1,
516             isa => Str,
517             format => 's',
518             doc =>
519             q{Divertion type. Possible values: "memory" (all diversions are kept in memory), "temp" (all diversions are kept in temporary files). Default: "memory".}
520             );
521              
522 1         1505 has _divert_type => (
523             is => 'rwp',
524             lazy => 1,
525             builder => 1,
526             isa => Enum [qw/memory file/]
527             );
528              
529 1 0   1   2999 method _trigger_divert_type (Str $divert_type, @rest --> Undef) {
  1 0   0   2  
  1 0       139  
  1 0       6  
  1 0       3  
  1 0       106  
  1         2705  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
530 0         0 $self->_set__divert_type($divert_type);
531 0         0 return;
532             }
533              
534 1 50   1   1083 method _build__divert_type {'memory'}
  1     24   3  
  1         278  
  1         2219  
  24         309  
  24         49  
  24         335  
535              
536             # =========================
537             # --builtin-need-param
538             # =========================
539 1         220 our $NEED_PARAM_DEFAULT_VALUE = [
540             qw/
541             define
542             undefine
543             defn
544             pushdef
545             popdef
546             indir
547             builtin
548             ifdef
549             ifelse
550             shift
551             changeword
552             m4wrap
553             include
554             sinclude
555             len
556             index
557             regexp
558             substr
559             translit
560             patsubst
561             format
562             incr
563             decr
564             eval
565             syscmd
566             esyscmd
567             mkstemp
568             maketemp
569             errprint
570             /
571             ];
572             option builtin_need_param => (
573             is => 'rw',
574             isa => ArrayRef [Str],
575             trigger => 1,
576             format => 's@',
577             autosplit => ',',
578             handles_via => 'Array',
579             handles => { builtin_need_param_elements => 'elements' },
580 140         48222 default => sub { return $NEED_PARAM_DEFAULT_VALUE },
581             doc =>
582             "Recognized-only-with-parameters policy. Repeatable option. Multiple values can be given in the same switch if separated by the comma character ','. Says if a macro is recognized only if it is immediately followed by a left parenthesis. Every option value is subject to the value of word_regexp: if it matches word_regexp at the beginning, then the option is considered. Any attempt to set it on the command-line will completely overwrite the default. Default: "
583 1         9 . join( ',', @{$NEED_PARAM_DEFAULT_VALUE} ) . '.'
  1         116  
584             );
585              
586 1         2677 has _builtin_need_param => (
587             is => 'rwp',
588             lazy => 1,
589             builder => 1,
590             isa => HashRef [Bool],
591             handles_via => 'Hash',
592             handles => {
593             _builtin_need_param_set => 'set',
594             _builtin_need_param_get => 'get',
595             _builtin_need_param_exists => 'exists',
596             _builtin_need_param_keys => 'keys',
597             _builtin_need_param_delete => 'delete'
598             },
599             );
600              
601 1 0   1   3496 method _trigger_builtin_need_param (ArrayRef[Str] $builtin_need_param, @rest --> Undef) {
  1 0   0   2  
  1 0       145  
  1 0       6  
  1 0       2  
  1 0       337  
  1         6465  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
602 0         0 my $r = $self->_regexp_word;
603 0         0 foreach ( @{$builtin_need_param} ) {
  0         0  
604 0 0       0 if ( $r->regexp_exec( $self, $_ ) == 0 ) {
605 0         0 my $lpos;
606             my $length;
607              
608 0 0       0 if ( $r->regexp_lpos_count > 1 ) {
609 0         0 $lpos = $r->regexp_lpos_get(1);
610 0         0 $length = $r->regexp_rpos_get(1) - $lpos;
611             }
612             else {
613 0         0 $lpos = $r->regexp_lpos_get(0);
614 0         0 $length = $r->regexp_rpos_get(0) - $lpos;
615             }
616              
617 0         0 $self->_builtin_need_param_set( substr( $_, $lpos, $length ),
618             true );
619             }
620             else {
621 0         0 $self->logger_warn( '%s: %s: does not match word regexp',
622             'builtin_need_param', $_ );
623             }
624             }
625 0         0 return;
626             }
627              
628 1 50   1   1115 method _build__builtin_need_param {
  1     138   3  
  1         464  
  1         2511  
  138         4293  
  138         315  
629 138         270 my %ref = map { $_ => true } @{$NEED_PARAM_DEFAULT_VALUE};
  4002         13381  
  138         563  
630 138         5430 \%ref;
631             }
632              
633             # =========================
634             # --param-can-be-macro
635             # =========================
636 1         174 our $PARAMCANBEMACRO_DEFAULT_VALUE_HASH = {
637             define => {
638             0 => true, # To trigger a warning
639             1 => true
640             },
641             pushdef => { 1 => true },
642             indir => {
643             '*' => true # To trigger a warning
644             },
645             builtin => {
646             '*' => true # To trigger a warning
647             },
648             };
649             our $PARAMCANBEMACRO_DEFAULT_VALUE = [
650             map {
651 4         8 my $macroName = $_;
652             "$macroName=" . join(
653             ':',
654             grep {
655 5         20 $PARAMCANBEMACRO_DEFAULT_VALUE_HASH->{$macroName}->{$_}
656             } keys
657 4         8 %{ $PARAMCANBEMACRO_DEFAULT_VALUE_HASH->{$macroName} }
  4         11  
658             )
659 1         19 } keys %{$PARAMCANBEMACRO_DEFAULT_VALUE_HASH}
  1         4  
660             ];
661              
662             option param_can_be_macro => (
663             is => 'rw',
664             isa => ArrayRef [Str],
665             trigger => 1,
666             format => 's@',
667             autosplit => ',',
668             handles_via => 'Array',
669             handles => { param_can_be_macro_elements => 'elements' },
670 140         6492 default => sub { return $NEED_PARAM_DEFAULT_VALUE },
671             doc =>
672             "Can-a-macro-parameter-be-an-internal-macro-token policy. Repeatable option. Multiple values can be given in the same switch if separated by the comma character ','. Says if a macro parameter can be an internal token, i.e. a reference to another macro. Every option value is subject to the value of word_regexp: if it matches word_regexp at the beginning, then the option is considered. On the command-line, the format has to be: word-regexp=?numbersOrStarSeparatedByColon?. For example: --policy_paramcanbemacro popdef,ifelse=,define=1,xxx=3:4,yyy=* says that popdef and ifelse do not accept any parameter as macro, but parameter at indice 1 of the define macro can be such internal token, as well as indices 3 and 4 of xxx macro, and any indices of macro yyy. Any attempt to set it on the command-line will completely overwrite the default. Default: "
673 1         10 . join( ',', @{$PARAMCANBEMACRO_DEFAULT_VALUE} ) . '.'
  1         140  
674             );
675              
676 1         2748 has _param_can_be_macro => (
677             is => 'rwp',
678             lazy => 1,
679             builder => 1,
680             isa => HashRef [ HashRef [ PositiveOrZeroInt | Enum [qw/*/] ] ],
681             handles_via => 'Hash',
682             handles => {
683             _param_can_be_macro_set => 'set',
684             _param_can_be_macro_get => 'get',
685             _param_can_be_macro_exists => 'exists',
686             _param_can_be_macro_keys => 'keys',
687             _param_can_be_macro_delete => 'delete'
688             },
689             );
690              
691 1 0   1   3530 method _trigger_param_can_be_macro (ArrayRef[Str] $param_can_be_macro, @rest --> Undef) {
  1 0   0   4  
  1 0       228  
  1 0       7  
  1 0       2  
  1 0       705  
  1         8975  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
692 0         0 my $r = $self->_regexp_word;
693 0         0 my %ref = ();
694 0         0 foreach ( @{$param_can_be_macro} ) {
  0         0  
695 0 0       0 if ( $r->regexp_exec( $self, $_ ) == 0 ) {
696 0         0 my $macroName;
697             my $lpos;
698 0         0 my $nextPos;
699 0         0 my $length;
700              
701 0 0       0 if ( $r->regexp_lpos_count > 1 ) {
702 0         0 $lpos = $r->regexp_lpos_get(1);
703 0         0 $nextPos = $r->regexp_rpos_get(1);
704             }
705             else {
706 0         0 $lpos = $r->regexp_lpos_get(0);
707 0         0 $nextPos = $r->regexp_rpos_get(0);
708             }
709              
710 0         0 $length = $nextPos - $lpos;
711 0         0 $macroName = substr( $_, $lpos, $length );
712              
713 0         0 $ref{$macroName} = {};
714 0 0 0     0 if ( $nextPos < length($_)
      0        
715             && substr( $_, $nextPos++, 1 ) eq '='
716             && $nextPos < length($_) )
717             {
718 0         0 my $indicesToSplit = substr( $_, $nextPos );
719             my @indices
720 0 0       0 = grep { !Undef->check($_) && length("$_") > 0 }
  0         0  
721             split( /,/, $indicesToSplit );
722 0         0 foreach (@indices) {
723 0 0 0     0 if ( PositiveOrZeroInt->check($_)
      0        
724             || ( Str->check($_) && $_ eq '*' ) )
725             {
726 0         0 $ref{$macroName}->{$_} = true;
727             }
728             else {
729 0         0 $self->logger_warn(
730             '%s: %s: %s does not look like a positive or zero integer, or star character',
731             'policy_paramcanbemacro', $macroName, $_
732             );
733             }
734             }
735             }
736             }
737             else {
738 0         0 $self->logger_warn( '%s: %s does not match a word regexp',
739             'policy_paramcanbemacro', $_ );
740             }
741             }
742 0         0 $self->_set__param_can_be_macro( \%ref );
743 0         0 return;
744             }
745              
746             sub _build__param_can_be_macro {
747 138     138   5576 return $PARAMCANBEMACRO_DEFAULT_VALUE_HASH;
748             }
749              
750             # =========================
751             # --interactive
752             # =========================
753 1         2294 option interactive => (
754             is => 'rw',
755             isa => Bool,
756             negativable => 1,
757             # short => 'i',
758             trigger => 1,
759             doc =>
760             q{Read STDIN and parse it line by line, until EOF. Option is negativable with '--no-' prefix.}
761             );
762              
763 1 0   1   1481 method _dumpCurrent (--> Undef) {
  1 0   0   2  
  1         177  
  1         1376  
  0         0  
  0         0  
  0         0  
764 0         0 my $valueRef = $self->_diversions_get(0)->sref;
765              
766 0         0 my $old = STDOUT->autoflush(1);
767 0         0 print STDOUT ${$valueRef};
  0         0  
768 0         0 STDOUT->autoflush($old);
769              
770 0         0 ${$valueRef} = '';
  0         0  
771 0         0 return;
772             }
773              
774 1 0   1   3076 method _trigger_interactive (Bool $interactive, @rest --> Undef) {
  1 0   0   2  
  1 0       203  
  1 0       8  
  1 0       2  
  1 0       171  
  1         2292  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
775 0 0       0 if ($interactive) {
776 0         0 $self->impl_parseIncrementalFile('-');
777             }
778 0         0 return;
779             }
780              
781             # =========================
782             # --version
783             # =========================
784 1         2023 option version => (
785             is => 'rw',
786             isa => Bool,
787             negativable => 1,
788             short => 'v',
789             trigger => 1,
790             doc =>
791             q{Print the version number of the program on standard output, then immediately exit. Option is negativable with '--no-' prefix.}
792             );
793              
794 1 0   1   2858 method _trigger_version (Bool $version, @rest --> Undef) {
  1 0   0   2  
  1 0       135  
  1 0       6  
  1 0       2  
  1 0       108  
  1         1894  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
795 0 0       0 if ($version) {
796 0         0 my $CURRENTVERSION;
797             #
798             # Because $VERSION is generated by dzil, not available in dev. tree
799             #
800 1     1   6 no strict 'vars';
  1         1  
  1         211  
801 0   0     0 $CURRENTVERSION = $VERSION || 'dev';
802              
803 0         0 print "Version $CURRENTVERSION\n";
804 0         0 exit(EXIT_SUCCESS);
805             }
806 0         0 return;
807             }
808              
809             # =========================
810             # --prefix-builtins
811             # =========================
812 1         2255 option prefix_builtins => (
813             is => 'rw',
814             isa => Bool,
815             negativable => 1,
816             short => 'P',
817             trigger => 1,
818             doc =>
819             q{Prefix of all builtin macros with 'm4_'. Default: a false value. Option is negativable with '--no-' prefix.}
820             );
821              
822 1         1558 has _prefix_builtins => (
823             is => 'rwp',
824             lazy => 1,
825             builder => 1,
826             isa => Str,
827             );
828              
829 1 50   1   2950 method _trigger_prefix_builtins (Bool $prefix_builtins, @rest --> Undef) {
  1 50   1   8  
  1 50       137  
  1 50       6  
  1 50       1  
  1 50       108  
  1         2097  
  1         97  
  1         6  
  1         5  
  1         4  
  1         2  
  1         6  
  1         5  
  1         3  
830 1         22 $self->_set__prefix_builtins('m4_');
831 1         44 return;
832             }
833 1 50   1   1197 method _build__prefix_builtins {''}
  1     137   2  
  1         161  
  1         2279  
  137         2017  
  137         348  
  137         2139  
834              
835             # =========================
836             # --fatal-warnings
837             # =========================
838 1         169 option fatal_warnings => (
839             is => 'rw',
840             isa => PositiveInt,
841             repeatable => 1,
842             short => 'E',
843             trigger => 1,
844             doc =>
845             q{If unspecified, have no effect. If specified once, impl_rc() will return EXIT_FAILURE. If specified more than once, any warning is fatal. Default: a false value.}
846             );
847              
848 1         1272 has _fatal_warnings => (
849             is => 'rwp',
850             lazy => 1,
851             builder => 1,
852             isa => PositiveOrZeroInt
853             );
854              
855 1 50   1   3118 method _trigger_fatal_warnings (PositiveInt $fatal_warnings, @rest --> Undef) {
  1 50   1   3  
  1 50       135  
  1 50       6  
  1 50       2  
  1 50       114  
  1         1899  
  1         125  
  1         4  
  1         4  
  1         7  
  1         4  
  1         4  
  1         6  
  1         3  
856 1         22 $self->_set__fatal_warnings($fatal_warnings);
857 1         55 return;
858             }
859              
860 1 50   1   1108 method _build__fatal_warnings {0}
  1     13   3  
  1         107  
  1         2144  
  13         217  
  13         28  
  13         218  
861              
862             # =========================
863             # --silent
864             # =========================
865 1         179 option silent => (
866             is => 'rw',
867             default => false,
868             short => 'Q',
869             doc =>
870             q{Silent mode. If true all warnings will disappear. Default: a false value.}
871             );
872              
873 1         638 has _silent => (
874             is => 'rwp',
875             lazy => 1,
876             builder => 1,
877             );
878              
879 1 0   1   2933 method _trigger_silent (Bool $silent, @rest --> Undef) {
  1 0   0   2  
  1 0       200  
  1 0       8  
  1 0       2  
  1 0       146  
  1         1016  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
880 0         0 $self->_set__silent($silent);
881 0         0 return;
882             }
883              
884 1 0   1   1007 method _build__silent {false}
  1     0   2  
  1         310  
  1         2171  
  0         0  
  0         0  
  0         0  
885              
886             # =========================
887             # --trace
888             # =========================
889             option trace => (
890             is => 'rw',
891             isa => ArrayRef [Str],
892 0         0 default => sub { [] },
893             format => 's@',
894             # short => 't',
895             autosplit => ',',
896             trigger => 1,
897             handles_via => 'Array',
898             handles => { trace_elements => 'elements' },
899 140         6244 default => sub { return [] },
900 1         196 doc =>
901             q{Trace mode. Repeatable option. Multiple values can be given in the same switch if separated by the comma character ','. Every option value will set trace on the macro sharing this name. Default is empty.}
902             );
903              
904 1         2825 has _trace => (
905             is => 'rwp',
906             lazy => 1,
907             builder => 1,
908             isa => HashRef [Bool],
909             handles_via => 'Hash',
910             handles => {
911             _trace_set => 'set',
912             _trace_get => 'get',
913             _trace_exists => 'exists',
914             _trace_keys => 'keys',
915             _trace_delete => 'delete'
916             }
917             );
918              
919 1 0   1   3287 method _trigger_trace (ArrayRef[Str] $arrayRef, @rest --> Undef) {
  1 0   0   3  
  1 0       134  
  1 0       9  
  1 0       3  
  1 0       148  
  1         5650  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
920 0         0 $self->impl_reloadState;
921 0         0 foreach ( @{$arrayRef} ) {
  0         0  
922 0         0 $self->_trace_set($_);
923             }
924 0         0 return;
925             }
926 1 50   1   1075 method _build__trace { {} }
  1     138   2  
  1         137  
  1         2292  
  138         23980  
  138         258  
  138         2146  
927              
928             # =========================
929             # --define
930             # =========================
931             option define => (
932             is => 'rw',
933             isa => ArrayRef [Str],
934             handles_via => 'Array',
935             handles => { define_elements => 'elements' },
936 140         7174 default => sub { return [] },
937 1         165 format => 's@',
938             short => 'D',
939             trigger => 1,
940             doc =>
941             q{Macro definition. Repeatable option. Every option value is subject to the value of word_regexp: if it matches word_regexp at the beginning, then a macro is declared. For example: --define myMacro. Or --word_regexp x= --define x=. Default expansion is void, unless the matched name is followed by '=', then any remaining character will be the expansion of this new macro. For example: --define myMacro=myExpansion. Or --word_regexp x= --define x==myExpansion. Default is empty.}
942             );
943              
944 1 0   1   3377 method _trigger_define (ArrayRef[Str] $arrayRef, @rest --> Undef) {
  1 0   0   2  
  1 0       163  
  1 0       8  
  1 0       2  
  1 0       534  
  1         2615  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
945 0         0 $self->impl_reloadState;
946 0         0 my $r = $self->_regexp_word;
947 0         0 foreach ( @{$arrayRef} ) {
  0         0  
948 0 0       0 if ( $r->regexp_exec( $self, $_ ) == 0 ) {
949 0         0 my $macroName;
950             my $lpos;
951 0         0 my $nextPos;
952 0         0 my $length;
953              
954 0 0       0 if ( $r->regexp_lpos_count > 1 ) {
955 0         0 $lpos = $r->regexp_lpos_get(1);
956 0         0 $nextPos = $r->regexp_rpos_get(1);
957             }
958             else {
959 0         0 $lpos = $r->regexp_lpos_get(0);
960 0         0 $nextPos = $r->regexp_rpos_get(0);
961             }
962              
963 0         0 $length = $nextPos - $lpos;
964 0         0 $macroName = substr( $_, $lpos, $length );
965              
966 0         0 my $value = substr( $_, $nextPos );
967 0 0       0 if ( length($value) > 0 ) {
968 0 0       0 if ( substr( $value, 0, 1 ) ne '=' ) {
969 0         0 $self->logger_warn( '%s: %s: not in form name=value',
970             'define', $_ );
971             }
972             else {
973 0         0 substr( $value, 0, 1, '' );
974             }
975             }
976 0         0 $self->builtin_define( $macroName, $value );
977             }
978             else {
979 0         0 $self->logger_warn( '%s: %s: does not match word regexp',
980             'define', $_ );
981             }
982             }
983 0         0 return;
984             }
985              
986             # =========================
987             # --undefine
988             # =========================
989             option undefine => (
990             is => 'rw',
991             isa => ArrayRef [Str],
992             handles_via => 'Array',
993             handles => { undefine_elements => 'elements' },
994 140         6023 default => sub { return [] },
995 1         2102 format => 's',
996             short => 'U',
997             repeatable => 1,
998             trigger => 1,
999             doc =>
1000             q{Macro undefinition. Repeatable option. Every option value is subject to the value of word_regexp: if it matches word_regexp at the beginning, then a macro is deleted if it exists. Default is empty.}
1001             );
1002              
1003 1 0   1   3539 method _trigger_undefine (ArrayRef[Str] $arrayRef, @rest --> Undef) {
  1 0   0   2  
  1 0       140  
  1 0       6  
  1 0       3  
  1 0       437  
  1         2503  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1004 0         0 $self->impl_reloadState;
1005 0         0 my $r = $self->_regexp_word;
1006 0         0 foreach ( @{$arrayRef} ) {
  0         0  
1007 0 0       0 if ( $r->regexp_exec( $self, $_ ) == 0 ) {
1008 0         0 my $macroName;
1009             my $lpos;
1010 0         0 my $length;
1011              
1012 0 0       0 if ( $r->regexp_lpos_count > 1 ) {
1013 0         0 $lpos = $r->regexp_lpos_get(1);
1014 0         0 $length = $r->regexp_rpos_get(1) - $lpos;
1015             }
1016             else {
1017 0         0 $lpos = $r->regexp_lpos_get(0);
1018 0         0 $length = $r->regexp_rpos_get(0) - $lpos;
1019             }
1020              
1021 0         0 $macroName = substr( $_, $lpos, $length );
1022 0         0 $self->builtin_undefine($macroName);
1023             }
1024             else {
1025 0         0 $self->logger_warn( '%s: %s: does not match word regexp',
1026             'undefine', $_ );
1027             }
1028             }
1029 0         0 return;
1030             }
1031              
1032             # =========================
1033             # --prepend-include
1034             # =========================
1035             option prepend_include => (
1036             is => 'rw',
1037             isa => ArrayRef [Str],
1038             handles_via => 'Array',
1039             handles => { prepend_include_elements => 'elements' },
1040 140         6169 default => sub { return [] },
1041 1         1968 format => 's@',
1042             short => 'B',
1043             trigger => 1,
1044             doc =>
1045             q{Include directory. Repeatable option. Will be used in reverse order and before current directory when searching for a file to include. Default is empty.}
1046             );
1047              
1048 1         2674 has _prepend_include => (
1049             is => 'rwp',
1050             lazy => 1,
1051             builder => 1,
1052             isa => ArrayRef [Str],
1053             handles_via => 'Array',
1054             handles => { _prepend_include_elements => 'elements', },
1055             );
1056              
1057 1 0   1   3765 method _trigger_prepend_include (ArrayRef[Str] $prepend_include, @rest --> Undef) {
  1 0   0   2  
  1 0       139  
  1 0       6  
  1 0       2  
  1 0       138  
  1         3865  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1058 0         0 $self->_set__prepend_include($prepend_include);
1059 0         0 return;
1060             }
1061 1 50   1   1140 method _build__prepend_include { [] }
  1     20   4  
  1         207  
  1         2406  
  20         629  
  20         47  
  20         303  
1062              
1063             # =========================
1064             # --include
1065             # =========================
1066             option include => (
1067             is => 'rw',
1068             isa => ArrayRef [Str],
1069             handles_via => 'Array',
1070             handles => { include_elements => 'elements' },
1071 140         9511 default => sub { return [] },
1072 1         205 format => 's@',
1073             short => 'I',
1074             trigger => 1,
1075             doc =>
1076             q{Include directory. Repeatable option. Will be used in order and after current directory when searching for a file to include. Default is empty.}
1077             );
1078              
1079 1         2732 has _include => (
1080             is => 'rwp',
1081             lazy => 1,
1082             builder => 1,
1083             isa => ArrayRef [Str],
1084             handles_via => 'Array',
1085             handles => { _include_elements => 'elements', },
1086             );
1087              
1088 1 50   1   3591 method _trigger_include (ArrayRef[Str] $include, @rest --> Undef) {
  1 50   140   3  
  1 50       182  
  1 50       7  
  1 50       2  
  1 50       137  
  1         3656  
  140         14451  
  140         964  
  140         679  
  140         647  
  140         488  
  140         699  
  140         887  
  140         323  
1089 140         2891 $self->_set__include($include);
1090 140         4651 return;
1091             }
1092 1 0   1   1140 method _build__include { [] }
  1     0   2  
  1         113  
  1         2560  
  0         0  
  0         0  
  0         0  
1093              
1094             # =========================
1095             # --synclines
1096             # =========================
1097 1         180 option synclines => (
1098             is => 'rw',
1099             isa => Bool,
1100             negativable => 1,
1101             # short => 's',
1102             trigger => 1,
1103             doc =>
1104             q{Generate synchronization lines. Although option exist it is not yet supported. Option is negativable with '--no-' prefix.}
1105             );
1106              
1107 1         1689 has _synclines => (
1108             is => 'rwp',
1109             lazy => 1,
1110             builder => 1,
1111             isa => Bool,
1112             );
1113              
1114 1 0   1   2837 method _trigger_synclines (Bool $synclines, @rest --> Undef) {
  1 0   0   2  
  1 0       130  
  1 0       6  
  1 0       2  
  1 0       102  
  1         2455  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1115 0         0 $self->_set__synclines($synclines);
1116 0         0 return;
1117             }
1118 1 0   1   1044 method _build__synclines { return false }
  1     0   3  
  1         126  
  1         2582  
  0         0  
  0         0  
  0         0  
1119              
1120             # =========================
1121             # --gnu
1122             # =========================
1123 1         224 option gnu => (
1124             is => 'rw',
1125             isa => Bool,
1126             negativable => 1,
1127             short => 'g',
1128             trigger => 1,
1129             doc =>
1130             q{Enable all extensions. Option is negativable with '--no-' prefix.}
1131             );
1132              
1133 1         1716 has _no_gnu_extensions => (
1134             is => 'rwp',
1135             lazy => 1,
1136             builder => 1,
1137             isa => Bool
1138             );
1139              
1140 1 0   1   2804 method _trigger_gnu (Bool $gnu, @rest --> Undef) {
  1 0   0   2  
  1 0       138  
  1 0       6  
  1 0       2  
  1 0       118  
  1         2296  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1141 0         0 $self->_set__no_gnu_extensions( !$gnu );
1142 0         0 return;
1143             }
1144 1 50   1   1136 method _build__no_gnu_extensions {false}
  1     137   2  
  1         118  
  1         2396  
  137         1795  
  137         254  
  137         442  
1145              
1146             # =========================
1147             # --traditional
1148             # =========================
1149 1         167 option traditional => (
1150             is => 'rw',
1151             isa => Bool,
1152             negativable => 1,
1153             short => 'G',
1154             trigger => 1,
1155             doc =>
1156             q{Suppress all extensions. Option is negativable with '--no-' prefix.}
1157             );
1158              
1159 1 50   1   3023 method _trigger_traditional (Bool $traditional, @rest --> Undef) {
  1 50   1   2  
  1 50       132  
  1 50       7  
  1 50       6  
  1 50       295  
  1         1610  
  1         143  
  1         5  
  1         6  
  1         6  
  1         3  
  1         6  
  1         29  
  1         3  
1160 1         29 $self->_set__no_gnu_extensions($traditional);
1161 1         71 return;
1162             }
1163              
1164             # =========================
1165             # --debugmode
1166             # =========================
1167 1         2125 our @DEBUG_FLAGS = qw/a c e f i l p q t x/;
1168 1         4 our @DEFAULT_DEBUG_FLAGS = qw/a e q/;
1169 1         8 option debug => (
1170             is => 'rw',
1171             isa => Str,
1172             trigger => 1,
1173             format => 's',
1174             short => 'd',
1175             doc => 'Debug mode. This is a combinaison of flags, that can be: "'
1176             . join( '", "', @DEBUG_FLAGS )
1177             . '", or "V" wich will put everything on. Default: "'
1178             . join( '', @DEFAULT_DEBUG_FLAGS ) . '".'
1179             );
1180              
1181 1         1378 has _debug => (
1182             is => 'rwp',
1183             lazy => 1,
1184             builder => 1,
1185             isa => HashRef [Bool],
1186             handles_via => 'Hash',
1187             handles => {
1188             _debug_set => 'set',
1189             _debug_get => 'get',
1190             _debug_exists => 'exists',
1191             _debug_keys => 'keys',
1192             _debug_delete => 'delete'
1193             }
1194             );
1195              
1196 1 0   1   2867 method _trigger_debug (Str $flags, @rest --> Undef) {
  1 0   0   4  
  1 0       186  
  1 0       7  
  1 0       3  
  1 0       502  
  1         6008  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1197              
1198 0         0 map { $self->_debug_set( $_, false ) } @DEBUG_FLAGS;
  0         0  
1199              
1200 0 0       0 if ( length($flags) <= 0 ) {
1201 0         0 map { $self->_debug_set( $_, true ) } @DEFAULT_DEBUG_FLAGS;
  0         0  
1202             }
1203             else {
1204             #
1205             # Only know debug flags are accepted
1206             #
1207 0         0 my $ok = 1;
1208 0         0 my @flags = split( //, $flags );
1209 0         0 foreach ( @flags, 'V' ) {
1210 0 0 0     0 if ( !$self->_debug_exists($_) && $_ ne 'V' ) {
1211 0         0 $self->logger_warn( '%s: unknown debug flag: %c',
1212             'debugmode', $_ );
1213 0         0 $ok = 0;
1214 0         0 last;
1215             }
1216             }
1217 0 0       0 if ( !$ok ) {
1218 0         0 return;
1219             }
1220 0 0       0 if ( index( $flags, 'V' ) >= 0 ) {
1221             #
1222             # Everything is on
1223             #
1224 0         0 map { $self->_debug_set( $_, true ) } @DEBUG_FLAGS;
  0         0  
1225             }
1226             else {
1227 0         0 map { $self->_debug_set( $_, false ) } @DEBUG_FLAGS;
  0         0  
1228 0         0 map { $self->_debug_set( $_, true ) } @flags;
  0         0  
1229             }
1230             }
1231              
1232 0         0 return;
1233             }
1234              
1235 1 50   1   1058 method _build__debug {
  1     138   2  
  1         253  
  1         2305  
  138         4484  
  138         270  
1236 138         323 my %ref = ();
1237 138         483 map { $ref{$_} = false } @DEBUG_FLAGS;
  1380         6675  
1238 138         943 map { $ref{$_} = true } @DEFAULT_DEBUG_FLAGS;
  414         1497  
1239 138         2799 return \%ref;
1240             }
1241              
1242             # =========================
1243             # --nesting_limit
1244             # =========================
1245 1         166 our $DEFAULT_NESTING_LIMIT = 1024;
1246 1         7 option nesting_limit => (
1247             is => 'rw',
1248             isa => PositiveOrZeroInt,
1249             trigger => 1,
1250             format => 'i',
1251             short => 'L',
1252             doc =>
1253             q{Should artificially limit the nesting of macro calls to num levels, stopping program execution if this limit is ever exceeded. This option is supported but has no effect. Must be a positive or zero integer. Default is 1024.}
1254             );
1255              
1256 1         1284 has _nesting_limit => (
1257             is => 'rwp',
1258             lazy => 1,
1259             builder => 1,
1260             isa => PositiveOrZeroInt
1261             );
1262              
1263 1 0   1   3117 method _trigger_nesting_limit (PositiveOrZeroInt $nesting_limit, @rest --> Undef) {
  1 0   0   2  
  1 0       192  
  1 0       7  
  1 0       2  
  1 0       106  
  1         1781  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1264 0         0 $self->_set__nesting_limit($nesting_limit);
1265             }
1266              
1267 1 0   1   1120 method _build__nesting_limit {$DEFAULT_NESTING_LIMIT}
  1     0   3  
  1         167  
  1         2431  
  0         0  
  0         0  
  0         0  
1268              
1269             # =========================
1270             # --debugfile
1271             # =========================
1272 1         171 our $DEFAULT_DEBUGFILE = undef;
1273 1         6 option debugfile => (
1274             is => 'rw',
1275             isa => Str,
1276             trigger => 1,
1277             format => 's',
1278             short => 'o',
1279             doc =>
1280             q{Debug file. An empty value disable debug output. A null value redirects to standard error. Default is a null value.}
1281             );
1282              
1283 1         1600 has _debugfile => (
1284             is => 'rwp',
1285             lazy => 1,
1286             builder => 1,
1287             isa => Undef | Str,
1288             );
1289              
1290 1 0   1   2885 method _trigger_debugfile (Str $debugfile, @rest --> Undef) {
  1 0   0   2  
  1 0       141  
  1 0       6  
  1 0       7  
  1 0       100  
  1         3056  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1291 0         0 $self->_set__debugfile($debugfile);
1292             }
1293              
1294 1 50   1   1098 method _build__debugfile {$DEFAULT_DEBUGFILE}
  1     2   4  
  1         168  
  1         2406  
  2         47  
  2         7  
  2         40  
1295              
1296             # =========================
1297             # --quote-start
1298             # =========================
1299 1         170 our $DEFAULT_QUOTE_START = '`';
1300 1         6 option quote_start => (
1301             is => 'rw',
1302             isa => Str,
1303             trigger => 1,
1304             format => 's',
1305             doc =>
1306             "Quote start. An empty option value is ignored. Default: \"$DEFAULT_QUOTE_START\"."
1307             );
1308              
1309 1         1447 has _quote_start => (
1310             is => 'rwp',
1311             lazy => 1,
1312             builder => 1,
1313             trigger => 1,
1314             isa => Str,
1315             );
1316              
1317 1         2360 has _quoteStartLength => (
1318             is => 'rwp',
1319             lazy => 1,
1320             builder => 1,
1321             isa => PositiveOrZeroInt
1322             );
1323              
1324 1 0   1   2962 method _trigger_quote_start (Str $quote_start, @rest --> Undef) {
  1 0   0   3  
  1 0       141  
  1 0       7  
  1 0       2  
  1 0       136  
  1         1818  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1325 0 0       0 if ( length($quote_start) > 0 ) {
1326 0         0 $self->_set__quote_start($quote_start);
1327             }
1328             }
1329              
1330 1 50   1   3006 method _trigger__quote_start (Str $quote_start, @rest --> Undef) {
  1 50   23   2  
  1 50       170  
  1 50       7  
  1 50       2  
  1 50       114  
  1         2161  
  23         1893  
  23         81  
  23         85  
  23         80  
  23         50  
  23         87  
  23         129  
  23         45  
1331 23         471 $self->_set__quoteStartLength( length($quote_start) );
1332             }
1333              
1334 1 50   1   1096 method _build__quote_start {$DEFAULT_QUOTE_START}
  1     139   3  
  1         85  
  1         2054  
  139         2118  
  139         245  
  139         2257  
1335 1 50   1   1136 method _build__quoteStartLength { length($DEFAULT_QUOTE_START) }
  1     139   3  
  1         189  
  1         170  
  139         1867  
  139         247  
  139         2229  
1336              
1337             # =========================
1338             # --quote-end
1339             # =========================
1340 1         164 our $DEFAULT_QUOTE_END = '\'';
1341 1         6 option quote_end => (
1342             is => 'rw',
1343             isa => Str,
1344             trigger => 1,
1345             format => 's',
1346             doc =>
1347             "Quote end. An empty option value is ignored. Default: \"$DEFAULT_QUOTE_END\"."
1348             );
1349              
1350 1         1586 has _quote_end => (
1351             is => 'rwp',
1352             lazy => 1,
1353             builder => 1,
1354             trigger => 1,
1355             isa => Str,
1356             );
1357              
1358 1         2280 has _quoteEndLength => (
1359             is => 'rwp',
1360             lazy => 1,
1361             builder => 1,
1362             isa => PositiveOrZeroInt
1363             );
1364              
1365 1 0   1   3027 method _trigger_quote_end (Str $quote_end, @rest --> Undef) {
  1 0   0   2  
  1 0       139  
  1 0       7  
  1 0       1  
  1 0       146  
  1         1795  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1366 0 0       0 if ( length($quote_end) > 0 ) {
1367 0         0 $self->_set__quote_end($quote_end);
1368             }
1369             }
1370              
1371 1 50   1   3384 method _trigger__quote_end (Str $quote_end, @rest --> Undef) {
  1 50   23   3  
  1 50       169  
  1 50       7  
  1 50       2  
  1 50       114  
  1         2179  
  23         1675  
  23         91  
  23         84  
  23         87  
  23         47  
  23         93  
  23         81  
  23         51  
1372 23         470 $self->_set__quoteEndLength( length($quote_end) );
1373             }
1374              
1375 1 50   1   1232 method _build__quote_end {$DEFAULT_QUOTE_END}
  1     139   4  
  1         112  
  1         2131  
  139         1859  
  139         261  
  139         2236  
1376 1 50   1   1107 method _build__quoteEndLength { length($DEFAULT_QUOTE_END) }
  1     139   2  
  1         212  
  1         177  
  139         1739  
  139         295  
  139         2128  
1377              
1378             # =========================
1379             # --comment-start
1380             # =========================
1381 1         164 our $DEFAULT_COMMENT_START = '#';
1382 1         6 option comment_start => (
1383             is => 'rw',
1384             isa => Str,
1385             trigger => 1,
1386             format => 's',
1387             doc =>
1388             "Comment start. An empty option value is ignored. Default: \"$DEFAULT_COMMENT_START\"."
1389             );
1390              
1391 1         1764 has _comment_start => (
1392             is => 'rwp',
1393             lazy => 1,
1394             builder => 1,
1395             trigger => 1,
1396             isa => Str,
1397             );
1398              
1399 1         2363 has _commentStartLength => (
1400             is => 'rwp',
1401             lazy => 1,
1402             builder => 1,
1403             isa => PositiveOrZeroInt
1404             );
1405              
1406 1 0   1   3004 method _trigger_comment_start (Str $comment_start, @rest --> Undef) {
  1 0   0   2  
  1 0       215  
  1 0       7  
  1 0       3  
  1 0       151  
  1         1789  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1407 0 0       0 if ( length($comment_start) > 0 ) {
1408 0         0 $self->_set__comment_start($comment_start);
1409             }
1410             }
1411              
1412 1 50   1   3043 method _trigger__comment_start (Str $comment_start, @rest --> Undef) {
  1 50   16   4  
  1 50       143  
  1 50       7  
  1 50       2  
  1 50       107  
  1         2991  
  16         1127  
  16         57  
  16         65  
  16         62  
  16         28  
  16         60  
  16         54  
  16         38  
1413 16         301 $self->_set__commentStartLength( length($comment_start) );
1414             }
1415              
1416 1 50   1   1180 method _build__comment_start {$DEFAULT_COMMENT_START}
  1     139   2  
  1         250  
  1         2167  
  139         2156  
  139         284  
  139         2316  
1417              
1418             sub _build__commentStartLength {
1419 139     139   3548 return length($DEFAULT_COMMENT_START);
1420             }
1421              
1422             # =========================
1423             # --comment-end
1424             # =========================
1425 1         180 our $DEFAULT_COMMENT_END = "\n";
1426 1         6 option comment_end => (
1427             is => 'rw',
1428             isa => Str,
1429             trigger => 1,
1430             format => 's',
1431             doc =>
1432             "Comment end. An empty option value is ignored. Default value: the newline character."
1433             );
1434              
1435 1         1717 has _comment_end => (
1436             is => 'rwp',
1437             lazy => 1,
1438             builder => 1,
1439             trigger => 1,
1440             isa => Str,
1441             );
1442              
1443 1         2322 has _commentEndLength => (
1444             is => 'rwp',
1445             lazy => 1,
1446             builder => 1,
1447             isa => PositiveOrZeroInt
1448             );
1449              
1450 1 0   1   2890 method _trigger_comment_end (Str $comment_end, @rest --> Undef) {
  1 0   0   3  
  1 0       174  
  1 0       7  
  1 0       2  
  1 0       156  
  1         1796  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1451 0 0       0 if ( length($comment_end) > 0 ) {
1452 0         0 $self->_set__comment_end($comment_end);
1453             }
1454             }
1455              
1456 1 50   1   2915 method _trigger__comment_end (Str $comment_end, @rest --> Undef) {
  1 50   16   2  
  1 50       139  
  1 50       7  
  1 50       2  
  1 50       108  
  1         2141  
  16         1104  
  16         57  
  16         62  
  16         58  
  16         30  
  16         155  
  16         64  
  16         38  
1457 16         357 $self->_set__commentEndLength( length($comment_end) );
1458             }
1459              
1460 1 50   1   1056 method _build__comment_end {$DEFAULT_COMMENT_END}
  1     139   2  
  1         95  
  1         1896  
  139         1855  
  139         312  
  139         2313  
1461 1 50   1   1184 method _build__commentEndLength { length($DEFAULT_COMMENT_END) }
  1     139   3  
  1         291  
  1         179  
  139         1938  
  139         290  
  139         2130  
1462              
1463             # =========================
1464             # --word-regexp
1465             # =========================
1466             #
1467             # Note: it appears that the default regexp works with both perl and GNU Emacs engines
1468             #
1469 1         168 our $DEFAULT_WORD_REGEXP = '[_a-zA-Z][_a-zA-Z0-9]*';
1470 1         4 option word_regexp => (
1471             is => 'rw',
1472             isa => Str,
1473             trigger => 1,
1474             format => 's',
1475             short => 'W',
1476             doc =>
1477             "Word regular expression. Default: \"$DEFAULT_WORD_REGEXP\" (equivalent between perl and GNU Emacs engines)."
1478             );
1479              
1480 1         1548 has _word_regexp => (
1481             is => 'rwp',
1482             lazy => 1,
1483             builder => 1,
1484             isa => Str
1485             );
1486              
1487 1         2146 has _regexp_word => (
1488             is => 'rwp',
1489             lazy => 1,
1490             builder => 1,
1491             isa => InstanceOf [M4Regexp]
1492             );
1493              
1494 1         2859 has _regexp_isDefault => (
1495             is => 'rwp',
1496             default => true,
1497             isa => Bool
1498             );
1499              
1500 1 50   1   2908 method _trigger_word_regexp (Str $regexpString, @rest --> Undef) {
  1 50   11   3  
  1 50       161  
  1 50       10  
  1 50       4  
  1 50       272  
  1         1461  
  11         1119  
  11         54  
  11         59  
  11         52  
  11         28  
  11         68  
  11         53  
  11         27  
1501 11 50       76 if ( length($regexpString) <= 0 ) {
1502 0         0 $regexpString = $DEFAULT_WORD_REGEXP;
1503             }
1504             #
1505             # Check it compiles.
1506             # If $regexpString is $DEFAULT_WORD_REGEXP we force the perl
1507             # mode because:
1508             # - regexp is the same between perl and re::engine::GNU
1509             # - perl version is (much faster)
1510             #
1511 11 50       378 my $regexp_type
1512             = ( $regexpString eq $DEFAULT_WORD_REGEXP )
1513             ? 'perl'
1514             : $self->_regexp_type;
1515 11         464 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1516 11 50       557 if ( $r->regexp_compile( $self, $regexp_type, $regexpString ) ) {
1517 11         705 $self->_set__word_regexp($regexpString);
1518 11         739 $self->_set__regexp_word($r);
1519             }
1520             $self->_set__regexp_isDefault(
1521 11 50       1296 ( $regexpString eq $DEFAULT_WORD_REGEXP ) ? true : false );
1522              
1523 11         747 return;
1524             }
1525              
1526             #
1527             # Why perltidier does not like it without @args ?
1528             #
1529 1 50   1   1513 method _build__word_regexp (@args) {
  1 50   139   3  
  1         140  
  1         2245  
  139         1894  
  139         508  
  139         334  
1530 139         2246 return $DEFAULT_WORD_REGEXP;
1531             }
1532              
1533 1 50   1   1710 method _build__regexp_word (@args) {
  1 50   139   2  
  1         300  
  1         190  
  139         1950  
  139         520  
  139         334  
1534 139         3130 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1535 139 50       7864 my $regexp_type
1536             = ( $self->_word_regexp eq $DEFAULT_WORD_REGEXP )
1537             ? 'perl'
1538             : $self->_regexp_type;
1539 139         5940 $r->regexp_compile( $self, $regexp_type, $self->_word_regexp );
1540 139         2889 return $r;
1541             }
1542              
1543             # ============================
1544             # --warn-macro-sequence-regexp
1545             # ============================
1546 1         223 our $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_GNU
1547             = '\$\({[^}]*}\|[0-9][0-9]+\)';
1548 1         5 our $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_PERL
1549             = '\$(\{[^\}]*\}|[0-9][0-9]+)';
1550 1         7 option warn_macro_sequence_regexp => (
1551             is => 'rw',
1552             isa => Str,
1553             trigger => 1,
1554             format => 's',
1555             doc =>
1556             "Regexp used to trigger a warning in macro definition when --warn-macro-sequence option is setted. Take care, the option value will have to obey current --regex-type (i.e. perl or GNU Emacs syntax). Perl default: \"$DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_PERL\", GNU default: \"$DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_GNU\"."
1557             );
1558              
1559 1         1463 has _warn_macro_sequence_regexp => (
1560             is => 'rwp',
1561             lazy => 1,
1562             builder => 1,
1563             isa => M4Regexp
1564             );
1565              
1566 1 50   1   1164 method _build__warn_macro_sequence_regexp {
  1     1   5  
  1         128  
  1         2370  
  1         19  
  1         4  
1567 1 50       22 my $regexpString
1568             = ( $self->_regexp_type eq 'GNU' )
1569             ? $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_GNU
1570             : $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_PERL;
1571 1         47 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1572 1         35 $r->regexp_compile( $self, $self->_regexp_type, $regexpString );
1573 1         36 return $r;
1574             }
1575              
1576 1 0   1   2942 method _trigger_warn_macro_sequence_regexp (Str $regexpString, @rest --> Undef) {
  1 0   0   2  
  1 0       144  
  1 0       26  
  1 0       4  
  1 0       269  
  1         201  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1577             #
1578             # Check it compiles
1579             #
1580 0         0 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1581 0 0       0 if ( $r->regexp_compile( $self, $self->_regexp_type, $regexpString ) )
1582             {
1583 0         0 $self->_set__warn_macro_sequence_regexp($r);
1584             }
1585 0         0 return;
1586             }
1587              
1588             # =========================
1589             # --warn-macro-sequence
1590             # =========================
1591 1         2381 our $DEFAULT_WARN_MACRO_SEQUENCE = false;
1592 1         9 option warn_macro_sequence => (
1593             is => 'rw',
1594             isa => Bool,
1595             default => false,
1596             trigger => 1,
1597             doc =>
1598             "Issue a warning if a macro defined via builtins define or pushdef is matching the regexp setted via --warn-macro-sequence-regexp option value. This is option is negativable. Default: a false value."
1599             );
1600              
1601 1         1567 has _warn_macro_sequence => (
1602             is => 'rwp',
1603             lazy => 1,
1604             builder => 1,
1605             isa => Bool
1606             );
1607              
1608 1 50   1   2917 method _trigger_warn_macro_sequence (Bool $bool, @rest --> Undef) {
  1 50   1   2  
  1 50       146  
  1 50       5  
  1 50       2  
  1 50       111  
  1         2124  
  1         91  
  1         5  
  1         7  
  1         4  
  1         2  
  1         7  
  1         4  
  1         2  
1609 1         114 $self->_set__warn_macro_sequence($bool);
1610 1         44 return;
1611             }
1612              
1613 1 50   1   1293 method _build__warn_macro_sequence {
  1     94   3  
  1         86  
  1         2012  
  94         1337  
  94         181  
1614 94         1603 return $DEFAULT_WARN_MACRO_SEQUENCE;
1615             }
1616              
1617             # ---------------------------------------------------------------
1618             # PARSER REQUIRED METHODS
1619             # ---------------------------------------------------------------
1620              
1621 1 50   1   6074 method parser_isWord (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   15088   2  
  1 50       157  
  1 50       6  
  1 50       2  
  1 50       117  
  1 50       7  
  1 50       2  
  1 50       107  
  1 50       6  
  1 50       3  
  1 50       101  
  1 50       6  
  1 50       2  
  1 50       157  
  1 50       7  
  1 50       2  
  1         514  
  1         275  
  15088         134490  
  15088         35115  
  15088         54900  
  15088         32957  
  15088         20799  
  15088         45732  
  15088         35864  
  15088         33114  
  15088         21109  
  15088         38390  
  15088         32730  
  15088         30107  
  15088         20291  
  15088         36871  
  15088         32137  
  15088         30578  
  15088         26607  
  15088         34084  
  15088         30232  
  15088         29532  
  15088         23433  
  15088         29781  
  15088         20730  
1622              
1623 15088         267974 my $r = $self->_regexp_word;
1624 15088 100       338812 if ( $r->regexp_exec( $self, $input, $pos ) == $pos ) {
1625 3091         42774 my $lposp = $r->regexp_lpos;
1626 3091         8356 my $rposp = $r->regexp_rpos;
1627 3091         11261 my $lpos;
1628             my $lposFull;
1629 3091         0 my $rpos;
1630 3091         0 my $rposFull;
1631              
1632 3091 100       5027 if ( $#{$lposp} > 0 ) {
  3091         8799  
1633 12         44 $lpos = $lposp->[1];
1634 12         36 $rpos = $rposp->[1];
1635 12 50       58 if ( $rpos <= $lpos ) {
1636 0         0 $lpos = $lposFull = $lposp->[0];
1637 0         0 $rpos = $rposFull = $rposp->[0];
1638             }
1639             else {
1640 12         40 $lposFull = $lposp->[0];
1641 12         34 $rposFull = $rposp->[0];
1642             }
1643             }
1644             else {
1645 3079         7010 $lpos = $lposFull = $lposp->[0];
1646 3079         7490 $rpos = $rposFull = $rposp->[0];
1647             }
1648              
1649 3091         6131 my $lexemeLength = $rposFull - $lposFull;
1650 3091         12851 my $lexemeValue = substr( $input, $lpos, $rpos - $lpos );
1651              
1652             #
1653             # There is an internal limitation:
1654             # if a regexp matches on characters abcdef,
1655             # then it must also match on a, ab, ..., abcde
1656             #
1657             #
1658             # Nevertheless we can bypass this horrible cost in one specific case:
1659             # the default value. We know that the default regexp is: [_a-zA-Z][_a-zA-Z0-9]*
1660             # i.e. per def when there is a match we /know/ it matches also character per
1661             # character.
1662             #
1663             # This can also be disabled with the option --no-changeword-is-character-per-character
1664             #
1665 3091 100 100     58472 if ( $self->_changeword_is_character_per_character
      100        
1666             && !$self->_regexp_isDefault
1667             &&
1668             #
1669             # No need to check character per character if the length that matched
1670             # (and not the captured group, eventually) is one character exactly
1671             #
1672             $lexemeLength > 1
1673             )
1674             {
1675 19         480 my $lengthFull = $rposFull - $lposFull;
1676 19         107 foreach ( 1 .. $lengthFull - 1 ) {
1677 61         768 my $substring = substr( $input, $lposFull, $_ );
1678 61 100       1431 if ( $r->regexp_exec( $self, $substring, 0 ) != 0 ) {
1679 2         36 return false;
1680             }
1681             }
1682             }
1683 3089         49190 ${$lexemeLengthRef} = $lexemeLength;
  3089         6665  
1684 3089         5658 ${$lexemeValueRef} = $lexemeValue;
  3089         5111  
1685 3089         11312 return true;
1686             }
1687              
1688 11997         162105 return false;
1689             }
1690              
1691 1 50   1   5810 method parser_isComment (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   23996   3  
  1 50       155  
  1 50       6  
  1 50       1  
  1 50       123  
  1 50       6  
  1 50       2  
  1 50       108  
  1 50       5  
  1 50       2  
  1 50       113  
  1 50       6  
  1 50       2  
  1 50       152  
  1 50       7  
  1 50       2  
  1         358  
  1         2023  
  23996         287770  
  23996         53684  
  23996         62059  
  23996         52479  
  23996         36041  
  23996         60666  
  23996         54891  
  23996         54152  
  23996         37266  
  23996         63329  
  23996         51507  
  23996         52485  
  23996         32236  
  23996         59115  
  23996         47577  
  23996         47021  
  23996         34861  
  23996         53777  
  23996         49394  
  23996         49214  
  23996         31915  
  23996         45188  
  23996         33504  
1692              
1693             #
1694             # We want to catch EOF in comment. So we do it ourself.
1695             #
1696 23996         406100 my $comStart = $self->_comment_start;
1697 23996         494285 my $comEnd = $self->_comment_end;
1698 23996         462928 my $commentStartLength = $self->_commentStartLength;
1699 23996         471920 my $commentEndLength = $self->_commentEndLength;
1700 23996 100 66     220953 if ( $commentStartLength > 0 && $commentEndLength > 0 ) {
1701              
1702 23916 100       216686 if ( substr( $input, $pos, $commentStartLength ) eq $comStart ) {
1703 81         172 my $lastPos = $pos + $commentStartLength;
1704 81         224 while ( $lastPos <= $maxPos ) {
1705 3075 100       4843 if ( substr( $input, $lastPos, $commentEndLength ) eq $comEnd ) {
1706 79         119 $lastPos += $commentEndLength;
1707 79         194 ${$lexemeLengthRef} = $lastPos - $pos;
  79         132  
1708 79         148 ${$lexemeValueRef}
1709 79         196 = substr( $input, $pos, ${$lexemeLengthRef} );
  79         160  
1710 79         273 return true;
1711             }
1712             else {
1713 2996         4672 ++$lastPos;
1714             }
1715             }
1716             #
1717             # If we are here, it is an error if End-Of-Input is flagged
1718             #
1719 2 50       13 if ( $self->_eof ) {
1720 2         39 $self->impl_raiseException('EOF in comment');
1721             }
1722             }
1723             }
1724 23915         66746 return false;
1725             }
1726              
1727 1 50   1   6012 method parser_isQuotedstring (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   21736   4  
  1 50       169  
  1 50       10  
  1 50       3  
  1 50       135  
  1 50       7  
  1 50       2  
  1 50       181  
  1 50       10  
  1 50       5  
  1 50       129  
  1 50       7  
  1 50       3  
  1 50       133  
  1 50       6  
  1 50       2  
  1         481  
  1         2093  
  21736         187029  
  21736         47660  
  21736         61314  
  21736         44865  
  21736         31124  
  21736         59388  
  21736         49848  
  21736         47003  
  21736         29340  
  21736         54713  
  21736         47047  
  21736         40207  
  21736         31412  
  21736         44613  
  21736         43595  
  21736         42033  
  21736         28482  
  21736         58045  
  21736         41575  
  21736         41254  
  21736         28735  
  21736         39060  
  21736         30192  
1728              
1729             #
1730             # We cannot rely on a balanced regexp a-la-Regexp::Common
1731             # because if end-string is a prefix of start-string, it has precedence
1732             #
1733 21736         375643 my $quoteStart = $self->_quote_start;
1734 21736         456689 my $quoteEnd = $self->_quote_end;
1735 21736         429022 my $quoteStartLength = $self->_quoteStartLength;
1736 21736         437570 my $quoteEndLength = $self->_quoteEndLength;
1737 21736 100 66     203928 if ( $quoteStartLength > 0 && $quoteEndLength > 0 ) {
1738              
1739 21716 100       212117 if ( substr( $input, $pos, $quoteStartLength ) eq $quoteStart ) {
1740 4394         8698 my $nested = 0;
1741 4394         8140 my $lastPos = $pos + $quoteStartLength;
1742 4394         9200 while ( $lastPos <= $maxPos ) {
1743 48304 100       96353 if (substr( $input, $lastPos, $quoteEndLength ) eq
    100          
1744             $quoteEnd )
1745             {
1746 7218         9351 $lastPos += $quoteEndLength;
1747 7218 100       12654 if ( $nested == 0 ) {
1748 4392         7392 ${$lexemeLengthRef} = $lastPos - $pos;
  4392         7794  
1749 4392         33206 ${$lexemeValueRef} = $self->impl_unquote(
1750 4392         7346 substr( $input, $pos, ${$lexemeLengthRef} ) );
  4392         80110  
1751 4392         16387 return true;
1752             }
1753             else {
1754 2826         4589 $nested--;
1755             }
1756             }
1757             elsif (
1758             substr( $input, $lastPos, $quoteStartLength ) eq
1759             $quoteStart )
1760             {
1761 2826         4475 $lastPos += $quoteStartLength;
1762 2826         4851 $nested++;
1763             }
1764             else {
1765 38260         59765 ++$lastPos;
1766             }
1767             }
1768             #
1769             # If we are here, it is an error if End-Of-Input is flagged
1770             #
1771 2 50       15 if ( $self->_eof ) {
1772 2         57 $self->impl_raiseException('EOF in string');
1773             }
1774             }
1775             }
1776 17342         54163 return false;
1777             }
1778              
1779 1 50   1   6110 method parser_isCharacter (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   7638   4  
  1 50       177  
  1 50       7  
  1 50       3  
  1 50       125  
  1 50       10  
  1 50       2  
  1 50       113  
  1 50       6  
  1 50       2  
  1 50       103  
  1 50       11  
  1 50       8  
  1 50       138  
  1 50       6  
  1 50       2  
  1         267  
  1         2250  
  7638         67895  
  7638         19961  
  7638         28682  
  7638         17289  
  7638         10692  
  7638         19445  
  7638         17450  
  7638         17236  
  7638         10824  
  7638         21011  
  7638         16083  
  7638         18016  
  7638         11737  
  7638         17821  
  7638         16120  
  7638         18629  
  7638         11618  
  7638         22868  
  7638         16619  
  7638         15633  
  7638         10570  
  7638         17253  
  7638         11155  
1780 7638         141466 pos($input) = $pos;
1781 7638 50       64436 if ( $input =~ /\G./s ) {
1782 7638         248973 ${$lexemeLengthRef} = $+[0] - $-[0];
  7638         17134  
1783 7638         74201 ${$lexemeValueRef} = substr( $input, $-[0], ${$lexemeLengthRef} );
  7638         13166  
  7638         73638  
1784 7638         26426 return true;
1785             }
1786 0         0 return false;
1787             }
1788              
1789 1 50   1   2401 method _getMacro (Str $word --> M4Macro) {
  1 50   2533   2  
  1 50       153  
  1 50       7  
  1 50       2  
  1         107  
  1         1986  
  2533         27716  
  2533         7427  
  2533         7731  
  2533         6777  
  2533         4549  
  2533         8383  
  2533         4782  
1790 2533         43257 return $self->_macros_get($word)->macros_get(-1);
1791             }
1792              
1793 1 50   1   7287 method parser_isMacro (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Str $wordValue, PositiveInt $wordLength, Ref $macroRef, Ref $lparenPosRef --> Bool) {
  1 50   3089   2  
  1 50       165  
  1 50       10  
  1 50       3  
  1 50       139  
  1 50       8  
  1 50       2  
  1 50       113  
  1 50       6  
  1 50       3  
  1 50       107  
  1 50       6  
  1 50       2  
  1 50       144  
  1 50       7  
  1 50       2  
  1 50       106  
  1 50       6  
  1 50       2  
  1 50       103  
  1 50       5  
  1 50       2  
  1         309  
  1         2694  
  3089         30916  
  3089         10095  
  3089         10366  
  3089         7851  
  3089         4150  
  3089         8686  
  3089         9135  
  3089         7829  
  3089         5019  
  3089         10409  
  3089         7731  
  3089         6902  
  3089         4430  
  3089         8785  
  3089         7964  
  3089         7557  
  3089         4527  
  3089         8254  
  3089         7897  
  3089         6961  
  3089         4598  
  3089         9542  
  3089         7253  
  3089         7076  
  3089         5963  
  3089         8248  
  3089         7566  
  3089         6608  
  3089         4430  
  3089         7877  
  3089         5021  
1794              
1795             #
1796             # If a macro with this name exist, we have to check if it is accepted.
1797             # The condition is if it is recognized only with parameters
1798             #
1799 3089 100       58521 if ( $self->_macros_exists($wordValue) ) {
1800 2443         169874 my $macro = $self->_getMacro($wordValue);
1801 2443         538294 my $lparenPos = $pos + $wordLength;
1802 2443         4990 my $dummy;
1803 2443 100 100     40651 my $lparen
    100          
1804             = (
1805             $self->parser_isQuotedstring( $input, $lparenPos, $maxPos,
1806             \$dummy, \$dummy )
1807             || $self->parser_isComment(
1808             $input, $lparenPos, $maxPos, \$dummy, \$dummy
1809             )
1810             ) ? ''
1811             : ( $lparenPos <= $maxPos ) ? substr( $input, $lparenPos, 1 )
1812             : '';
1813 2443 100 100     81807 if ( $lparen eq '(' || !$macro->macro_needParams ) {
1814 2441         20356 ${$macroRef} = $macro;
  2441         4829  
1815 2441 100       6351 ${$lparenPosRef} = ( $lparen eq '(' ) ? $lparenPos : -1;
  2441         4437  
1816 2441         7968 return true;
1817             }
1818             }
1819              
1820 648         34313 return false,;
1821             }
1822              
1823 1 50   1   1131 method parser_tokensPriority {
  1     2017   3  
  1         96  
  1         2029  
  2017         6934  
  2017         3383  
1824 2017         41385 return $self->_tokens_priority_elements;
1825             }
1826              
1827             # ---------------------------------------------------------------
1828             # LOGGER REQUIRED METHODS
1829             # ---------------------------------------------------------------
1830 1 50   1   1927 method logger_error (@args --> Undef) {
  1 50   40   2  
  1         137  
  1         180  
  40         2268  
  40         287  
  40         105  
1831             #
1832             # Localize anyway, because there can be an error within
1833             # new_with_options() -;
1834             #
1835 40         116 local $MarpaX::Languages::M4::SELF = $self;
1836 40         810 $self->_logger->errorf(@args);
1837 40         22313 return;
1838             }
1839              
1840 1 50   1   1986 method logger_warn (@args --> Undef) {
  1 50   28   2  
  1         259  
  1         1917  
  28         1241  
  28         186  
  28         80  
1841             #
1842             # Localize anyway, because there can be an error within
1843             # new_with_options() -;
1844             #
1845 28         70 local $MarpaX::Languages::M4::SELF = $self;
1846 28 50       180 if ( !$self->silent ) {
1847 28         537 $self->_logger->warnf(@args);
1848             }
1849 28 100       12549 if ( $self->_fatal_warnings >= 1 ) {
1850 2         81 $self->_set__rc(EXIT_FAILURE);
1851             }
1852 28 100       1222 if ( $self->_fatal_warnings > 1 ) {
1853             #
1854             # Say we do not accept more input
1855             #
1856 2         60 $self->impl_setEoi;
1857 2         43 $self->impl_raiseException('Warning is fatal');
1858             }
1859 26         271 return;
1860             }
1861              
1862 1 50   1   2297 method _canDebug (Str $what --> Bool) {
  1 50   116   2  
  1 50       178  
  1 50       7  
  1 50       2  
  1         88  
  1         1980  
  116         1011  
  116         312  
  116         329  
  116         292  
  116         163  
  116         348  
  116         193  
1863             #
1864             # A macro is debugged if 't' is setted,
1865             # or if it is explicitely traced
1866             #
1867 116         1940 return $self->_debug_get($what);
1868             }
1869              
1870 1 50 33 1   3136 method _canTrace (ConsumerOf[M4Macro] $macro --> Bool) {
  1 50   2450   6  
  1 50       174  
  1 50       7  
  1 50       1  
  1 50       194  
  1         1937  
  2450         23208  
  2450         6094  
  2450         7468  
  2450         6066  
  2450         3751  
  2450         4278  
  2450         12132  
  2450         11258  
  2450         8170  
  2450         55177  
1871             #
1872             # A macro is debugged if 't' is setted,
1873             # or if it is explicitely traced
1874             #
1875 2450 50 33     47127 if ( !$self->_debug_get('t') && !$self->_trace_get( $macro->name ) ) {
1876 2450         499661 return false;
1877             }
1878              
1879 0         0 return true;
1880             }
1881              
1882 1 50   1   1905 method logger_debug (@args --> Undef) {
  1 50   3   3  
  1         134  
  1         1895  
  3         259  
  3         21  
  3         9  
1883 3         9 local $MarpaX::Languages::M4::SELF = $self;
1884 3         70 $self->_logger->debugf(@args);
1885 3         1439 return;
1886             }
1887              
1888             #
1889             # _canTrace is called upper
1890             #
1891 1 0   1   1967 method logger_trace (@args --> Undef) {
  1 0   0   2  
  1         250  
  1         1916  
  0         0  
  0         0  
  0         0  
1892 0         0 local $MarpaX::Languages::M4::SELF = $self;
1893 0         0 $self->_logger->tracef(@args);
1894 0         0 return;
1895             }
1896              
1897             # ---------------------------------------------------------------
1898             # PRIVATE ATTRIBUTES
1899             # ---------------------------------------------------------------
1900 1         1998 has _lastSysExitCode => ( is => 'rw', isa => Int, default => 0 );
1901              
1902 1         1790 has __file__ => ( is => 'rwp', isa => Str, default => '' );
1903 1         1332 has __line__ => ( is => 'rwp', isa => PositiveOrZeroInt, default => 0 );
1904              
1905             # Saying directly $0 failed in taint mode
1906 1         1135 has __program__ => ( is => 'rwp', isa => Str, default => sub {$0} );
  140         6554  
1907              
1908 1         1297 has _value => (
1909             is => 'rwp',
1910             isa => Str,
1911             default => ''
1912             );
1913              
1914             # ----------------------------------------------------
1915             # builders
1916             # ----------------------------------------------------
1917              
1918 1 0   1   1061 method _build_quote_start {$DEFAULT_QUOTE_START}
  1     0   4  
  1         76  
  1         1261  
  0         0  
  0         0  
  0         0  
1919              
1920 1 50   1   1064 method _build__logger_category {'M4'}
  1     34   3  
  1         90  
  1         242  
  34         1442  
  34         82  
  34         486  
1921              
1922             #
1923             # Diversion 0 is special and maps directly to an internal variable
1924             #
1925 1 50   1   1128 method _build__diversions { { 0 => IO::Scalar->new } }
  1     140   3  
  1         100  
  1         176  
  140         4726  
  140         260  
  140         1312  
1926              
1927 1 50   1   1054 method _build__lastDiversion { $self->_diversions_get(0) }
  1     118   2  
  1         74  
  1         234  
  118         1708  
  118         233  
  118         2320  
1928              
1929 1 50   1   1175 method _build__builtins {
  1     138   2  
  1         934  
  1         198  
  138         4145  
  138         252  
1930 138         334 my %ref = ();
1931 138         735 foreach (
1932             qw/
1933             define undefine defn pushdef popdef indir builtin
1934             ifdef ifelse
1935             shift
1936             dumpdef
1937             traceon traceoff
1938             debugmode debugfile
1939             dnl
1940             changequote changecom changeword
1941             m4wrap
1942             m4exit
1943             include sinclude
1944             divert undivert divnum
1945             len index
1946             regexp substr translit patsubst
1947             format
1948             incr decr
1949             eval
1950             syscmd esyscmd sysval
1951             mkstemp maketemp
1952             errprint
1953             __file__ __line__ __program__
1954             /
1955             )
1956             {
1957              
1958 6210 50 100     103719 if ( $self->_no_gnu_extensions
      66        
1959             && exists( $Default_EXTENSIONS{$_} )
1960             && $Default_EXTENSIONS{$_} )
1961             {
1962 10         120 next;
1963             }
1964 6200         54987 my $stubName = "builtin_$_";
1965 6200         109025 $ref{$_} = MarpaX::Languages::M4::Impl::Macro->new(
1966             name => $_,
1967             #
1968             # Builtins have no extension
1969             #
1970             expansion => undef,
1971             #
1972             # I learned it the hard way: NEVER call meta in Moo,
1973             # this will load Moose
1974             #
1975             # stub => $self->meta->get_method("builtin_$_")->body
1976             stub => \&$stubName
1977             );
1978 6200 100       306801 if ( $self->_builtin_need_param_exists($_) ) {
1979 3995         241198 $ref{$_}->needParams( $self->_builtin_need_param_get($_) );
1980             }
1981 6200 100       666459 if ( $self->_param_can_be_macro_exists($_) ) {
1982 550         39458 $ref{$_}
1983             ->paramCanBeMacro( $self->_param_can_be_macro_get($_) );
1984             }
1985 6200 100       322888 if ( $_ eq 'dnl' ) {
1986             $ref{$_}->postMatchLength(
1987             sub {
1988 128     128   6783 my ( $self, $input, $pos, $maxPos ) = @_;
1989 128         777 pos($input) = $pos;
1990 128 100 33     1222 if ( $input =~ /\G.*?\n/s ) {
    50          
1991 127         1246 return $+[0] - $-[0];
1992             }
1993             elsif ( $self->_eof && $input =~ /\G[^\n]*\z/ ) {
1994 1         28 $self->logger_warn( '%s: %s',
1995             'dnl', 'EOF without a newline' );
1996 1         10 return $+[0] - $-[0];
1997             }
1998             else {
1999 0         0 return 0;
2000             }
2001             }
2002 138         3681 );
2003             }
2004             }
2005 138 100       2364 if ( !$self->_no_gnu_extensions ) {
2006 137         1220 my $name = '__gnu__';
2007             $ref{$name} = MarpaX::Languages::M4::Impl::Macro->new(
2008             name => $name,
2009             expansion => '',
2010 2     2   118 stub => sub { return ''; }
2011 137         2931 );
2012             }
2013 138 50       5432 if ( is_os_type('Windows') ) {
2014             #
2015             # A priori I assume this is reliable
2016             #
2017 0         0 my $name;
2018 0 0       0 if ( $^O eq 'os2' ) {
2019 0 0       0 $name = $self->_no_gnu_extensions ? 'os2' : '__os2__';
2020             }
2021             else {
2022 0 0       0 $name = $self->_no_gnu_extensions ? 'windows' : '__windows__';
2023             }
2024             $ref{$name} = MarpaX::Languages::M4::Impl::Macro->new(
2025             name => $name,
2026             expansion => '',
2027 0     0   0 stub => sub { return ''; }
2028 0         0 );
2029             }
2030 138 50       3239 if ( is_os_type('Unix') ) {
2031 138 100       3758 my $name = $self->_no_gnu_extensions ? 'unix' : '__unix__';
2032             $ref{$name} = MarpaX::Languages::M4::Impl::Macro->new(
2033             name => $name,
2034             expansion => '',
2035 0     0   0 stub => sub { return ''; }
2036 138         3711 );
2037             }
2038              
2039 138         7444 return \%ref;
2040             }
2041              
2042 1 50   1   1126 method _build__macros {
  1     138   2  
  1         211  
  1         183  
  138         4208  
  138         253  
2043 138         355 my %ref = ();
2044 138         2343 foreach ( $self->_builtins_keys ) {
2045 6475         385155 my $macros = MarpaX::Languages::M4::Impl::Macros->new();
2046 6475         256704 $macros->macros_push( $self->_builtins_get($_) );
2047 6475         1052350 $ref{ $self->_prefix_builtins . $_ } = $macros;
2048             }
2049 138         4340 return \%ref;
2050             }
2051              
2052             # ----------------------------------------------------
2053             # Triggers
2054             # ----------------------------------------------------
2055 1 50   1   3347 method _trigger__eoi (Bool $eoi, @rest --> Undef) {
  1 50   142   2  
  1 50       219  
  1 50       8  
  1 50       2  
  1 50       661  
  1         171  
  142         13352  
  142         555  
  142         534  
  142         525  
  142         248  
  142         613  
  142         551  
  142         375  
2056 142 50       482 if ($eoi) {
2057             #
2058             # First, m4wrap stuff is rescanned.
2059             # and each of them appears like an
2060             # independant input.
2061             #
2062 142         2819 while ( $self->_m4wrap_count > 0 ) {
2063 21         1613 my @m4wrap = $self->_m4wrap_elements;
2064 21         1460 $self->_set___m4wrap( [] );
2065 21 50       1075 $self->impl_parseIncremental(
2066             join( '',
2067             ( $self->_m4wrap_order eq 'FIFO' )
2068             ? @m4wrap
2069             : reverse @m4wrap )
2070             );
2071             }
2072             #
2073             # Then, diverted thingies, that are not rescanned
2074             # We make sure current diversion is number 0
2075 142         10391 $self->builtin_divert();
2076 142         2958 $self->builtin_undivert();
2077             }
2078 142         682 return;
2079             }
2080              
2081             # ----------------------------------------------------
2082             # Internal attributes
2083             # ----------------------------------------------------
2084 1         2299 has _macroCallId => (
2085             is => 'rwp',
2086             isa => PositiveOrZeroInt,
2087             default => 0
2088             );
2089              
2090 1         1328 has _rc => (
2091             is => 'rwp',
2092             isa => Int,
2093             default => EXIT_SUCCESS,
2094             );
2095              
2096 1         1420 has _builtins => (
2097             is => 'lazy',
2098             isa => HashRef [M4Macro],
2099             handles_via => 'Hash',
2100             handles => {
2101             _builtins_set => 'set',
2102             _builtins_get => 'get',
2103             _builtins_exists => 'exists',
2104             _builtins_keys => 'keys',
2105             _builtins_delete => 'delete'
2106             }
2107             );
2108              
2109 1         6778 has _macros => (
2110             is => 'lazy',
2111             isa => HashRef [ InstanceOf ['MarpaX::Languages::M4::Impl::Macros'] ],
2112             handles_via => 'Hash',
2113             handles => {
2114             _macros_set => 'set',
2115             _macros_get => 'get',
2116             _macros_exists => 'exists',
2117             _macros_keys => 'keys',
2118             _macros_delete => 'delete'
2119             }
2120             );
2121              
2122             has __m4wrap => (
2123             is => 'rwp',
2124             isa => ArrayRef [Str],
2125 140         2070801 default => sub { [] },
2126 1         6101 handles_via => 'Array',
2127             handles => {
2128             _m4wrap_push => 'push',
2129             _m4wrap_unshift => 'unshift',
2130             _m4wrap_elements => 'elements',
2131             _m4wrap_count => 'count',
2132             }
2133             );
2134              
2135 1         4224 has _eof => (
2136             is => 'rwp',
2137             isa => Bool,
2138             default => false
2139             );
2140              
2141 1         1329 has _eoi => (
2142             is => 'rwp',
2143             isa => Bool,
2144             trigger => 1,
2145             default => false
2146             );
2147              
2148 1         1409 has _unparsed => (
2149             is => 'rwp',
2150             isa => Str,
2151             default => ''
2152             );
2153              
2154 1         1287 has _diversions => (
2155             is => 'lazy',
2156             isa => HashRef [ ConsumerOf ['IO::Handle'] ],
2157             handles_via => 'Hash',
2158             handles => {
2159             _diversions_set => 'set',
2160             _diversions_get => 'get',
2161             _diversions_exists => 'exists',
2162             _diversions_keys => 'keys',
2163             _diversions_delete => 'delete'
2164             }
2165             );
2166              
2167 1         6955 has _lastDiversion => (
2168             is => 'rwp',
2169             lazy => 1,
2170             builder => 1,
2171             isa => ConsumerOf ['IO::Handle']
2172             );
2173             has _lastDiversionNumbers => (
2174             is => 'rwp',
2175             isa => ArrayRef [Int],
2176 140         15234 default => sub { [0] },
2177 1         2768 handles_via => 'Array',
2178             handles => {
2179             _lastDiversionNumbers_push => 'push',
2180             _lastDiversionNumbers_first_index => 'first_index',
2181             _lastDiversionNumbers_get => 'get',
2182             _lastDiversionNumbers_splice => 'splice'
2183             }
2184             );
2185              
2186 1 50   1   2424 method impl_quote (Str $string --> Str) {
  1 50   1377   5  
  1 50       168  
  1 50       8  
  1 50       3  
  1         196  
  1         4912  
  1377         14019  
  1377         3179  
  1377         3128  
  1377         2905  
  1377         1731  
  1377         3708  
  1377         1984  
2187 1377 50 33     20368 if ( $self->_quoteStartLength > 0 && $self->_quoteEndLength > 0 ) {
2188 1377         53172 return $self->_quote_start . $string . $self->_quote_end;
2189             }
2190             else {
2191 0         0 return $string;
2192             }
2193             }
2194              
2195 1 50   1   2236 method impl_unquote (Str $string --> Str) {
  1 50   4392   3  
  1 50       140  
  1 50       5  
  1 50       2  
  1         147  
  1         2263  
  4392         36733  
  4392         10109  
  4392         19902  
  4392         11469  
  4392         7044  
  4392         11129  
  4392         7908  
2196 4392 50 33     67113 if ( $self->_quoteStartLength > 0 && $self->_quoteEndLength > 0 ) {
2197 4392         171158 substr( $string, 0, $self->_quoteStartLength, '' );
2198 4392         91182 my $quoteEndLength = $self->_quoteEndLength;
2199 4392         35333 substr( $string, -$quoteEndLength, $quoteEndLength, '' );
2200             }
2201 4392         67074 return $string;
2202             }
2203              
2204 1 50   1   2914 method _checkIgnored (Str $name, @ignored --> Undef) {
  1 50   1457   2  
  1 50       148  
  1 50       6  
  1 50       5  
  1 100       149  
  1         1643  
  1457         14792  
  1457         4611  
  1457         4927  
  1457         4994  
  1457         2389  
  1457         5241  
  1457         4921  
  1457         2438  
2205 1457 100       4464 if (@ignored) {
2206 2         45 $self->logger_warn( 'excess arguments to builtin %s ignored',
2207             $self->impl_quote($name) );
2208             }
2209 1457         3309 return;
2210             }
2211              
2212 1 50 66 1   6965 method builtin_define (Undef|Str|M4Macro $name?, Undef|Str|M4Macro $defn?, @ignored --> Str) {
  1 50 66 314   3  
  1 50       180  
  1 50       7  
  1 50       2  
  1 50       251  
  1 50       7  
  1 50       2  
  1         421  
  1         2091  
  314         23751  
  314         1076  
  314         969  
  314         543  
  314         2124  
  314         1158  
  314         956  
  314         589  
  314         1864  
  314         1187  
  314         790  
2213 314 50       1060 if ( Undef->check($name) ) {
2214 0         0 $self->logger_error(
2215             'too few arguments to builtin %s',
2216             $self->impl_quote('define')
2217             );
2218 0         0 return '';
2219             }
2220 314   50     3493 $defn //= '';
2221              
2222 314         6339 $self->_checkIgnored( 'define', @ignored );
2223              
2224 314 100       1103 if ( M4Macro->check($name) ) {
2225 2         99 $self->logger_warn(
2226             '%s: invalid macro name ignored',
2227             $self->impl_quote('define')
2228             );
2229 2         33 return '';
2230             }
2231              
2232 312         4050 my $macro;
2233 312 100       1121 if ( Str->check($defn) ) {
2234             #
2235             # Make a M4Macro out of $defn
2236             #
2237 307         8549 $macro = MarpaX::Languages::M4::Impl::Macro->new(
2238             name => $name,
2239             stub => $self->_expansion2CodeRef( $name, $defn ),
2240             expansion => $defn
2241             );
2242             }
2243             else {
2244 5         131 $macro = $defn->macro_clone($name);
2245             }
2246 310 100       19637 if ( !$self->_macros_exists($name) ) {
2247 192         14458 my $macros = MarpaX::Languages::M4::Impl::Macros->new();
2248 192         9817 $macros->macros_push($macro);
2249 192         13163 $self->_macros_set( $name, $macros );
2250             }
2251             else {
2252 118         8549 $self->_macros_get($name)->macros_set( -1, $macro );
2253             }
2254 310         49715 return '';
2255             }
2256              
2257 1 50   1   3071 method builtin_undefine (Str @names --> Str) {
  1 50   9   3  
  1 50       133  
  1         6  
  1         2  
  1         123  
  1         1779  
  9         772  
  9         58  
  9         31  
  10         25  
  10         45  
  9         20  
2258 9         196 $self->_macros_delete(@names);
2259 9         1524 return '';
2260             }
2261              
2262             #
2263             # defn can only concatenate text macros
2264             #
2265 1 50   1   2929 method builtin_defn (Str @names --> Str|M4Macro) {
  1 50   74   4  
  1 50       150  
  1         7  
  1         3  
  1         407  
  1         1843  
  74         5022  
  74         384  
  74         217  
  78         130  
  78         291  
  74         162  
2266 74         182 my @macros = ();
2267              
2268 74         212 foreach (@names) {
2269 78 50       2311 if ( $self->_macros_exists($_) ) {
2270 78         4756 push( @macros, $self->_getMacro($_) );
2271             }
2272             }
2273              
2274 74         15348 my $rc = '';
2275 74         342 foreach ( 0 .. $#macros ) {
2276 78 100       1356 if ( $macros[$_]->macro_isBuiltin ) {
2277 18 100 100     1174 if ( ( $_ == 0 && $#macros > 0 )
      100        
2278             || ( $_ > 0 ) )
2279             {
2280 3         70 $self->logger_warn( '%s: cannot concatenate builtin %s',
2281             'defn',
2282             $self->impl_quote( $macros[$_]->macro_name ) );
2283             }
2284             else {
2285             #
2286             # Per def this is ok only
2287             # if @macros has one element,
2288             # and this is a builtin
2289             #
2290 15         75 $rc = $macros[$_];
2291             }
2292             }
2293             else {
2294 60         3506 $rc .= $self->impl_quote( $macros[$_]->macro_expansion );
2295             }
2296             }
2297 74         3493 return $rc;
2298             }
2299              
2300 1 50 66 1   6024 method builtin_pushdef (Undef|Str $name?, Undef|Str|M4Macro $defn?, @ignored --> Str) {
  1 50   66   2  
  1 50       143  
  1 50       6  
  1 100       3  
  1 50       148  
  1 100       6  
  1 50       3  
  1         456  
  1         6858  
  66         4464  
  66         309  
  66         235  
  66         131  
  66         316  
  66         251  
  66         260  
  59         134  
  59         455  
  66         313  
  66         129  
2301 66 50       196 if ( Undef->check($name) ) {
2302 0         0 $self->logger_error(
2303             'too few arguments to builtin %s',
2304             $self->impl_quote('pushdef')
2305             );
2306 0         0 return '';
2307             }
2308              
2309 66         721 my $macro;
2310 66   100     223 $defn //= '';
2311              
2312 66         1325 $self->_checkIgnored( 'pushdef', @ignored );
2313              
2314 66 100       194 if ( Str->check($defn) ) {
2315             #
2316             # Make a M4Macro out of $defn
2317             #
2318 63         1607 $macro = MarpaX::Languages::M4::Impl::Macro->new(
2319             name => $name,
2320             stub => $self->_expansion2CodeRef( $name, $defn ),
2321             expansion => $defn
2322             );
2323             }
2324             else {
2325 3         72 $macro = $defn->macro_clone($name);
2326             }
2327 66 100       3624 if ( !$self->_macros_exists($name) ) {
2328 30         1865 my $macros = MarpaX::Languages::M4::Impl::Macros->new();
2329 30         1298 $macros->macros_push($macro);
2330 30         1732 $self->_macros_set( $name, $macros );
2331             }
2332             else {
2333 36         2137 $self->_macros_get($name)->macros_push($macro);
2334             }
2335 66         9204 return '';
2336             }
2337              
2338 1 50   1   2454 method builtin_popdef (Str @names --> Str) {
  1 50   51   2  
  1 50       168  
  1         10  
  1         3  
  1         220  
  1         1832  
  51         3510  
  51         263  
  51         166  
  54         115  
  54         219  
  51         95  
2339              
2340 51         129 foreach (@names) {
2341 54 50       1405 if ( $self->_macros_exists($_) ) {
2342 54         3257 $self->_macros_get($_)->macros_pop();
2343 54 100       9584 if ( $self->_macros_get($_)->macros_isEmpty ) {
2344 26         4144 $self->_macros_delete($_);
2345             }
2346             }
2347             }
2348 51         6753 return '';
2349             }
2350              
2351 1 50 66 1   4415 method builtin_indir (Undef|Str|M4Macro $name, @args --> Str|M4Macro) {
  1 50   10   2  
  1 50       159  
  1 50       6  
  1 50       5  
  1 100       488  
  1         1852  
  10         788  
  10         52  
  10         56  
  10         46  
  10         28  
  10         121  
  10         74  
  10         25  
2352 10 50       38 if ( Undef->check($name) ) {
2353 0         0 $self->logger_error(
2354             'too few arguments to builtin %s',
2355             $self->impl_quote('indir')
2356             );
2357 0         0 return '';
2358             }
2359             #
2360             # If $name is a builtin, check the other arguments
2361             #
2362 10 100       137 if ( M4Macro->check($name) ) {
2363 1         50 $self->logger_warn(
2364             'indir: invalid macro name ignored',
2365             $self->impl_quote( $name->macro_name )
2366             );
2367 1         16 return '';
2368             }
2369 9 100       297 if ( $self->_macros_exists($name) ) {
2370 7         531 my $macro = $self->_getMacro($name);
2371             #
2372             # Check the args
2373             #
2374 7         1625 foreach ( 0 .. $#args ) {
2375 6 100 100     58 if ( M4Macro->check( $args[$_] )
2376             && !$macro->macro_paramCanBeMacro($_) )
2377             {
2378             #
2379             # Macro not authorized: flattened to the empty string
2380             #
2381 1         27 $args[$_] = '';
2382             }
2383             }
2384             #
2385             # macro executed by indir is not traced
2386             #
2387 7         168 return $macro->macro_execute( $self, @args );
2388              
2389             # return $self->impl_macroExecute( $macro, @args );
2390             }
2391             else {
2392 2         149 $self->logger_error( 'indir: undefined macro %s',
2393             $self->impl_quote($name) );
2394 2         43 return '';
2395             }
2396             }
2397              
2398 1 50 33 1   4575 method builtin_builtin (Undef|Str|M4Macro $name?, @args --> Str|M4Macro) {
  1 100   16   2  
  1 50       145  
  1 100       6  
  1 100       3  
  1         465  
  1         6588  
  16         1157  
  16         65  
  16         66  
  15         34  
  15         141  
  16         76  
  16         42  
2399 16 100       92 if ( Undef->check($name) ) {
2400 1         28 $self->logger_error(
2401             'too few arguments to builtin %s',
2402             $self->impl_quote('builtin')
2403             );
2404 1         21 return '';
2405             }
2406 15 50       182 if ( M4Macro->check($name) ) {
2407             #
2408             # Not supported
2409             #
2410 0         0 $self->logger_error(
2411             '%s: invalid macro name ignored',
2412             $self->impl_quote('builtin')
2413             );
2414 0         0 return '';
2415             }
2416 15 100       454 if ( $self->_builtins_exists($name) ) {
2417             #
2418             # We do not check the args to eventually flatten them. Thus this
2419             # can throw an exception.
2420             #
2421 11         621 my $rc = '';
2422             try {
2423 11     11   724 $rc = $self->impl_macroExecute( $self->_builtins_get($name),
2424             @args );
2425             }
2426             catch {
2427 0     0   0 $self->logger_error( '%s', "$_" );
2428 0         0 return;
2429 11         119 };
2430 11         701 return $rc;
2431             }
2432             else {
2433 4         308 $self->logger_error( 'builtin: undefined builtin %s',
2434             $self->impl_quote($name) );
2435 4         88 return '';
2436             }
2437             }
2438              
2439 1 50   1   7120 method builtin_ifdef (Undef|Str $name?, Undef|Str $string1?, Undef|Str $string2?, @ignored --> Str) {
  1 50   62   3  
  1 50       156  
  1 50       7  
  1 50       5  
  1 50       117  
  1 50       6  
  1 100       2  
  1 50       113  
  1 100       6  
  1 100       1  
  1         230  
  1         6415  
  62         4560  
  62         325  
  62         236  
  62         152  
  62         338  
  62         254  
  62         239  
  62         112  
  62         224  
  62         235  
  62         205  
  19         41  
  19         70  
  62         215  
  62         137  
2440 62 50 33     193 if ( Undef->check($name) || Undef->check($string1) ) {
2441 0         0 $self->logger_error(
2442             'too few arguments to builtin %s',
2443             $self->impl_quote('ifdef')
2444             );
2445 0         0 return '';
2446             }
2447              
2448 62         2447 $self->_checkIgnored( 'ifdef', @ignored );
2449              
2450 62 100       1122 if ( $self->_macros_exists($name) ) {
2451 41         2675 return $string1;
2452             }
2453             else {
2454 21   100     1486 return $string2 // '';
2455             }
2456             }
2457              
2458 1 50   1   1944 method builtin_ifelse (@args --> Str) {
  1 50   252   3  
  1         441  
  1         1781  
  252         18955  
  252         1502  
  252         585  
2459 252         1203 while (@args) {
2460 293 100 66     2748 if ( scalar(@args) <= 1 ) {
    100          
    100          
2461 1         17 return '';
2462             }
2463             elsif ( scalar(@args) == 2 ) {
2464 1         20 $self->logger_error(
2465             'too few arguments to builtin %s',
2466             $self->impl_quote('ifelse')
2467             );
2468 1         21 return '';
2469             }
2470             elsif ( scalar(@args) >= 3 && scalar(@args) <= 5 ) {
2471 246         1206 my ( $string1, $string2, $equal, $notEqual, $ignored )
2472             = @args;
2473 246   50     912 $string1 //= '';
2474 246   50     1016 $string2 //= '';
2475 246   50     743 $equal //= '';
2476 246   100     736 $notEqual //= '';
2477 246 100       789 if ( !Undef->check($ignored) ) {
2478 2         61 $self->logger_warn(
2479             'excess arguments to builtin %s ignored',
2480             $self->impl_quote('ifelse') );
2481             }
2482 246 100       7345 return ( $string1 eq $string2 ) ? $equal : $notEqual;
2483             }
2484             else {
2485 45         210 my ( $string1, $string2, $equal, @rest ) = @args;
2486 45   50     187 $string1 //= '';
2487 45   50     175 $string2 //= '';
2488 45   50     178 $equal //= '';
2489 45 100       194 if ( $string1 eq $string2 ) {
2490 4         74 return $equal;
2491             }
2492 41         223 @args = @rest;
2493             }
2494             }
2495             }
2496              
2497 1 50   1   2046 method builtin_shift (@args --> Str) {
  1 50   151   2  
  1         202  
  1         1717  
  151         11170  
  151         812  
  151         335  
2498 151         331 shift(@args);
2499              
2500 151 100       553 if (@args) {
2501 133         358 return join( ',', map { $self->impl_quote($_) } @args );
  448         19777  
2502             }
2503             else {
2504 18         267 return '';
2505             }
2506             }
2507              
2508 1 50   1   1917 method builtin_dumpdef (@args --> Str) {
  1 50   4   3  
  1         277  
  1         1690  
  4         352  
  4         23  
  4         11  
2509              
2510 4 50       20 if ( !@args ) {
2511 0         0 @args = $self->_macros_keys;
2512             }
2513              
2514 4         20 foreach ( sort @args ) {
2515 4 100       88 if ( !$self->_macros_exists($_) ) {
2516 1         79 $self->logger_warn( 'dumpdef: undefined macro %s',
2517             $self->impl_quote($_) );
2518             }
2519             else {
2520 3 100       233 $self->logger_debug(
2521             '%s: %s',
2522             $_,
2523             $self->_getMacro($_)->macro_isBuiltin
2524             ? "<$_>"
2525             : $self->_getMacro($_)->macro_expansion
2526             );
2527             }
2528             }
2529              
2530 4         101 return '';
2531             }
2532              
2533 1 0   1   1951 method builtin_traceon (@names --> Str) {
  1 0   0   2  
  1         156  
  1         1795  
  0         0  
  0         0  
  0         0  
2534 0         0 foreach (@names) {
2535 0         0 $self->_trace_set( $_, true );
2536             }
2537 0         0 return '';
2538             }
2539              
2540 1 0   1   1909 method builtin_traceoff (@names --> Str) {
  1 0   0   2  
  1         182  
  1         1954  
  0         0  
  0         0  
  0         0  
2541 0         0 foreach (@names) {
2542 0         0 $self->_trace_set( $_, false );
2543             }
2544 0         0 return '';
2545             }
2546              
2547 1 0   1   3813 method builtin_debugmode (Undef|Str $flags?, @ignored --> Str) {
  1 0   0   2  
  1 0       162  
  1 0       10  
  1 0       4  
  1         223  
  1         1939  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2548 0 0 0     0 if ( Str->check($flags) && length($flags) <= 0 ) {
2549 0         0 $flags = 'aeq';
2550             }
2551 0 0       0 if ( Undef->check($flags) ) {
2552 0         0 $flags = '';
2553             }
2554              
2555 0         0 $self->_checkIgnored( 'debugmode', @ignored );
2556 0         0 $self->debugmode($flags);
2557 0         0 return '';
2558             }
2559              
2560 1 0   1   3900 method builtin_debugfile (Undef|Str $file?, @ignored --> Str) {
  1 0   0   2  
  1 0       131  
  1 0       6  
  1 0       2  
  1         124  
  1         1727  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2561              
2562 0         0 $self->_checkIgnored( 'debugfile', @ignored );
2563 0         0 $self->_set_debugfile($file);
2564 0         0 return '';
2565             }
2566              
2567 1 50   1   2063 method builtin_dnl (@ignored --> Str) {
  1 100   128   3  
  1         120  
  1         1629  
  128         10232  
  128         553  
  128         387  
2568 128         2674 $self->_checkIgnored( 'dnl', @ignored );
2569 128         2405 return '';
2570             }
2571              
2572 1 50   1   5694 method builtin_changequote (Undef|Str $start?, Undef|Str $end?, @ignored --> Str) {
  1 100   23   2  
  1 50       145  
  1 100       7  
  1 100       3  
  1 50       116  
  1 100       10  
  1 50       2  
  1         283  
  1         1721  
  23         2058  
  23         97  
  23         94  
  17         43  
  17         111  
  23         91  
  23         88  
  17         42  
  17         74  
  23         97  
  23         47  
2573 23 100 66     98 if ( Undef->check($start) && Undef->check($end) ) {
2574 6         141 $start = $DEFAULT_QUOTE_START;
2575 6         17 $end = $DEFAULT_QUOTE_END;
2576             }
2577              
2578 23         778 $self->_checkIgnored( 'changequote', @ignored );
2579              
2580 23   50     76 $start //= '';
2581 23 100       95 if ( length($start) <= 0 ) {
2582 1         4 $end = '';
2583             }
2584             else {
2585 22   66     82 $end ||= $DEFAULT_QUOTE_END;
2586             }
2587              
2588 23         577 $self->_set__quote_start($start);
2589 23         1496 $self->_set__quote_end($end);
2590              
2591 23         1370 return '';
2592             }
2593              
2594 1 50   1   5717 method builtin_changecom (Undef|Str $start?, Undef|Str $end?, @ignored --> Str) {
  1 100   16   3  
  1 50       137  
  1 100       7  
  1 100       2  
  1 50       243  
  1 100       7  
  1 50       2  
  1         333  
  1         1627  
  16         1227  
  16         71  
  16         79  
  13         31  
  13         74  
  16         71  
  16         61  
  13         28  
  13         55  
  16         75  
  16         37  
2595 16 100 66     55 if ( Undef->check($start) && Undef->check($end) ) {
2596 3         56 $start = '';
2597 3         6 $end = '';
2598             }
2599              
2600 16         497 $self->_checkIgnored( 'changecom', @ignored );
2601              
2602 16   50     55 $start //= '';
2603 16 100       73 if ( length($start) <= 0 ) {
2604 3         27 $end = '';
2605             }
2606             else {
2607 13   66     48 $end ||= $DEFAULT_COMMENT_END;
2608             }
2609              
2610 16         371 $self->_set__comment_start($start);
2611 16         1012 $self->_set__comment_end($end);
2612              
2613 16         956 return '';
2614             }
2615              
2616 1 50   1   3762 method builtin_changeword (Undef|Str $string?, @ignored --> Str) {
  1 50   11   4  
  1 50       136  
  1 50       7  
  1 50       1  
  1         178  
  1         1637  
  11         1097  
  11         57  
  11         59  
  11         23  
  11         80  
  11         58  
  11         32  
2617 11 50       53 if ( Undef->check($string) ) {
2618 0         0 $self->logger_error(
2619             'too few arguments to builtin %s',
2620             $self->impl_quote('changeword')
2621             );
2622 0         0 return '';
2623             }
2624 11         424 $self->_checkIgnored( 'changeword', @ignored );
2625              
2626 11         299 $self->word_regexp($string);
2627              
2628 11         293 return '';
2629             }
2630              
2631 1 50   1   2006 method builtin_m4wrap (@args --> Str) {
  1 50   22   3  
  1         175  
  1         1661  
  22         1906  
  22         140  
  22         64  
2632              
2633 22         65 my $text = join( ' ', grep { !Undef->check($_) } @args );
  22         97  
2634 22         743 $self->_m4wrap_push($text);
2635              
2636 22         1626 return '';
2637             }
2638              
2639 1 0   1   3579 method builtin_m4exit (Undef|Str $code?, @ignored --> Str) {
  1 0   0   2  
  1 0       160  
  1 0       7  
  1 0       2  
  1         308  
  1         1716  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2640              
2641 0         0 $self->_checkIgnored( 'm4exit', @ignored );
2642              
2643 0 0       0 if ( !Undef->check($code) ) {
2644 0 0       0 if ( !PositiveOrZeroInt->check($code) ) {
2645 0         0 $self->logger_error(
2646             '%s: %s: does not look like a positive or zero integer',
2647             'm4exit', $code );
2648 0         0 $code = EXIT_FAILURE;
2649             }
2650             }
2651              
2652             #
2653             # Remove all wrapped text, diversions and mark end of input
2654             #
2655 0         0 $self->_set___m4wrap( [] );
2656 0         0 foreach ( $self->_diversions_keys ) {
2657 0         0 my $number = $_;
2658 0 0 0     0 if ( Int->check($number) && $number == 0 ) {
2659             #
2660             # Diversion 0 is special -;
2661             #
2662 0         0 next;
2663             }
2664 0         0 $self->_remove_diversion($number);
2665             }
2666              
2667 0         0 $self->_set__rc($code);
2668 0         0 $self->impl_setEoi;
2669              
2670 0         0 return '';
2671             }
2672              
2673 1 50   1   3254 method _includeFile (Bool $silent, Str $wantedFile --> Str) {
  1 50   33   2  
  1 50       166  
  1 50       10  
  1 50       3  
  1 50       144  
  1 50       7  
  1 50       2  
  1         392  
  1         1959  
  33         997  
  33         144  
  33         126  
  33         124  
  33         74  
  33         161  
  33         120  
  33         143  
  33         66  
  33         112  
  33         63  
2674              
2675 33 100       167 if ( length($wantedFile) <= 0 ) {
2676 2 100       10 if ( !$silent ) {
2677             #
2678             # Fake a ENOENT
2679             #
2680 1 50       4 if ( exists &Errno::ENOENT ) {
2681 1         4 $! = &Errno::ENOENT;
2682 1         19 $self->logger_error( 'cannot open %s: %s',
2683             $self->impl_quote($wantedFile), $! );
2684             }
2685             else {
2686 0         0 $self->logger_error( 'cannot open %s',
2687             $self->impl_quote($wantedFile) );
2688             }
2689             }
2690 2         52 return '';
2691             }
2692 31         71 my @paths = ();
2693              
2694             my @includes = (
2695             reverse( $self->_prepend_include_elements ),
2696             File::Spec->curdir(),
2697             reverse( $self->_include_elements ),
2698 31 50 33     665 ( exists( $ENV{M4PATH} ) && defined( $ENV{M4PATH} ) )
2699             ? M4PATH->List
2700             : ()
2701             );
2702              
2703 31         4344 my $file;
2704 31 100       271 if ( File::Spec->file_name_is_absolute($wantedFile) ) {
2705 4         11 $file = $wantedFile;
2706             }
2707             else {
2708 1     1   566 use filetest 'access';
  1         13  
  1         7  
2709 27         75 foreach (
2710 54         1601 grep { -r $_ }
2711 54         605 map { File::Spec->catfile( $_, $wantedFile ) } @includes
2712             )
2713             {
2714 25         73 $file = $_;
2715 25         77 last;
2716             }
2717             }
2718              
2719 31 100       117 if ( !$file ) {
2720             #
2721             # It is guaranteed that #includes have at least one element.
2722             # Therefore, $! should be setted
2723             #
2724 2 100       8 if ( !$silent ) {
2725 1         21 $self->logger_error( 'cannot open %s: %s',
2726             $self->impl_quote($wantedFile), $! );
2727             }
2728 2         54 return '';
2729             }
2730              
2731 29 50       662 if ( $self->_canDebug('p') ) {
2732 0         0 $self->logger_debug(
2733             'path search for %s found %s',
2734             $self->impl_quote($wantedFile),
2735             $self->impl_quote($file)
2736             );
2737             }
2738              
2739 29         3508 my $content = '';
2740 29         129 my $previousFile = $self->__file__;
2741 29         104 my $previousLine = $self->__line__;
2742 29         126 $self->impl_parseIncrementalFile( $file, $silent, false, \$content );
2743 29 50       643 if ( $self->_canDebug('i') ) {
2744 0         0 $self->logger_debug(
2745             'input reverted to %s, line %d',
2746             $self->impl_quote($previousFile),
2747             $previousLine
2748             );
2749             }
2750 29         3477 $self->_set___file__($previousFile);
2751 29         1073 $self->_set___line__($previousLine);
2752              
2753 29         1503 return $content;
2754             }
2755              
2756 1 50   1   4149 method builtin_include (Undef|Str $file, @ignored --> Str) {
  1 50   31   2  
  1 50       178  
  1 50       7  
  1 50       2  
  1 50       183  
  1         1799  
  31         2190  
  31         128  
  31         125  
  31         118  
  31         51  
  31         179  
  31         130  
  31         66  
2757 31 50       103 if ( Undef->check($file) ) {
2758 0         0 $self->logger_error(
2759             'too few arguments to builtin %s',
2760             $self->impl_quote('include')
2761             );
2762 0         0 return '';
2763             }
2764 31         966 $self->_checkIgnored( 'include', @ignored );
2765              
2766 31         139 return $self->_includeFile( false, $file );
2767             }
2768              
2769 1 50   1   4225 method builtin_sinclude (Undef|Str $file, @ignored --> Str) {
  1 50   2   2  
  1 50       253  
  1 50       11  
  1 50       4  
  1 50       311  
  1         1628  
  2         158  
  2         11  
  2         12  
  2         11  
  2         6  
  2         16  
  2         11  
  2         6  
2770 2 50       9 if ( Undef->check($file) ) {
2771 0         0 $self->logger_error(
2772             'too few arguments to builtin %s',
2773             $self->impl_quote('sinclude')
2774             );
2775 0         0 return '';
2776             }
2777 2         87 $self->_checkIgnored( 'sinclude', @ignored );
2778              
2779 2         14 return $self->_includeFile( true, $file );
2780             }
2781              
2782 1 50 33 1   5654 method _apply_diversion (Int $number, ConsumerOf ['IO::Handle'] $fh --> Undef) {
  1 50 33 218   5  
  1 50       266  
  1 50       7  
  1 50       3  
  1 50       234  
  1 50       7  
  1 50       2  
  1 50       387  
  1         1724  
  218         2528  
  218         854  
  218         1058  
  218         743  
  218         472  
  218         2329  
  218         893  
  218         918  
  218         343  
  218         510  
  218         1163  
  218         1305  
  218         1990  
  218         506  
2783             my $index
2784 246     246   14393 = $self->_lastDiversionNumbers_first_index( sub { $_ == $number }
2785 218         5158 );
2786 218 100       1720 if ( $index >= 0 ) {
2787 185         3833 $self->_lastDiversionNumbers_splice( $index, 1 );
2788             }
2789 218         23390 $self->_lastDiversionNumbers_push($number);
2790 218 100       13350 if ( !$self->_diversions_exists($number) ) {
2791 33         1924 $self->_diversions_set( $number, $fh );
2792             }
2793 218         13652 $fh->autoflush(1);
2794 218         4314 $self->_set__lastDiversion($fh);
2795              
2796 218         8839 return;
2797             }
2798              
2799 1 50 33 1   2960 method _remove_diversion (Int $number --> Undef) {
  1 50   33   3  
  1 50       211  
  1 50       8  
  1 50       2  
  1         229  
  1         2203  
  33         320  
  33         127  
  33         165  
  33         99  
  33         57  
  33         362  
  33         67  
2800             my $index
2801 37     37   1645 = $self->_lastDiversionNumbers_first_index( sub { $_ == $number }
2802 33         633 );
2803 33 50       196 if ( $index >= 0 ) {
2804 33         585 $self->_lastDiversionNumbers_splice( $index, 1 );
2805 33         3175 $self->_diversions_delete($number);
2806             }
2807             else {
2808             #
2809             # This should not happen
2810             #
2811 0         0 $self->logger_error(
2812             '%s: cannot find internal diversion number %d',
2813             'divert', $number );
2814             }
2815             #
2816             # We don't know the $fh of previous diversion,
2817             # it is stored in diversions hash.
2818             #
2819 33         3653 $self->_set__lastDiversion(
2820             $self->_diversions_get( $self->builtin_divnum ) );
2821 33         6626 return;
2822             }
2823              
2824 1 50   1   4227 method builtin_divert (Undef|Str $number?, @ignored --> Str) {
  1 100   218   10  
  1 50       216  
  1 100       8  
  1 50       2  
  1         584  
  1         1925  
  218         6644  
  218         775  
  218         772  
  46         112  
  46         256  
  218         766  
  218         427  
2825 218         4037 $self->_checkIgnored( 'divert', @ignored );
2826              
2827 218   100     1324 $number //= 0;
2828 218 100       1130 if ( length("$number") <= 0 ) {
2829 1         20 $self->logger_warn( 'empty string treated as 0 in builtin %s',
2830             $self->impl_quote('divert') );
2831 1         3 $number = 0;
2832             }
2833 218 50       1047 if ( !Int->check($number) ) {
2834 0         0 $self->logger_error( '%s: %s: does not look like an integer',
2835             'divert', $number );
2836 0         0 return '';
2837             }
2838              
2839 218         3058 my $fh;
2840 218 100       841 if ( $number == 0 ) {
2841             #
2842             # Diversion number 0 is a noop and always goes to STDOUT.
2843             # We will just make sure this is current diversion number.
2844             # Per def this diversion always exist.
2845             #
2846 176         4048 $fh = $self->_diversions_get($number);
2847             }
2848             else {
2849 42 100       722 if ( !$self->_diversions_exists($number) ) {
2850             #
2851             # Create diversion
2852             #
2853             try {
2854 33 50   33   1967 if ( $self->_divert_type eq 'memory' ) {
2855 33         802 $fh = IO::Scalar->new;
2856             }
2857             else {
2858 0         0 $fh = File::Temp->new;
2859             #
2860             # We do not want to be exposed to any wide-character
2861             # warning
2862             #
2863 0         0 binmode($fh);
2864             }
2865             }
2866             catch {
2867 0     0   0 $self->logger_error("$_");
2868 0         0 return;
2869 33         3702 };
2870 33 50       1644 if ( Undef->check($fh) ) {
2871 0         0 return '';
2872             }
2873             }
2874             else {
2875             #
2876             # Get diversion $fh
2877             #
2878 9         626 $fh = $self->_diversions_get($number);
2879             }
2880             }
2881             #
2882             # Make sure latest diversion number is $number
2883             #
2884 218         25058 $self->_apply_diversion( $number, $fh );
2885 218         1646 return '';
2886             }
2887              
2888 1 50   1   1200 method _diversions_sortedKeys {
  1     145   2  
  1         114  
  1         1756  
  145         482  
  145         371  
2889 145         3112 return sort { $a <=> $b } $self->_diversions_keys;
  29         1383  
2890             }
2891              
2892 1 50   1   2770 method builtin_undivert (Str @diversions --> Str) {
  1 100   157   2  
  1 50       151  
  1         7  
  1         3  
  1         445  
  1         223  
  157         2634  
  157         764  
  157         499  
  15         25  
  15         55  
  157         332  
2893              
2894             #
2895             # Undiverting the empty string is the same as specifying diversion 0
2896             #
2897 157         595 foreach ( 0 .. $#diversions ) {
2898 15 100       67 if ( length( $diversions[$_] ) <= 0 ) {
2899 1         3 $diversions[$_] = '0';
2900             }
2901             }
2902              
2903 157 100       538 if ( !@diversions ) {
2904 145         686 @diversions = $self->_diversions_sortedKeys;
2905             }
2906              
2907 157         7675 foreach (@diversions) {
2908 186         528 my $number = $_;
2909 186 100       596 if ( Int->check($number) ) {
2910             #
2911             # Undiverting the current diversion, or number 0,
2912             # or a unknown diversion is silently ignored.
2913             #
2914 183 100 100     5138 if ( $number == $self->builtin_divnum
      100        
2915             || $number == 0
2916             || !$self->_diversions_exists($number) )
2917             {
2918 150         10741 next;
2919             }
2920             #
2921             # Only positive numbers are merged
2922             #
2923 33 100       4047 if ( $number > 0 ) {
2924             #
2925             # This is per-def a IO::Handle consumer
2926             #
2927 18         268 my $fh = $self->_diversions_get($number);
2928             #
2929             # Get its size
2930             #
2931 18         1478 $fh->seek( 0, SEEK_END );
2932 18         352 my $size = $fh->tell;
2933             #
2934             # Go to the beginning
2935             #
2936 18         121 $fh->seek( 0, SEEK_SET );
2937             #
2938             # Read it
2939             #
2940 18         199 my $content = '';
2941 18         79 $fh->read( $content, $size );
2942             #
2943             # Now we can really remove this diversion
2944             #
2945 18         584 $self->_remove_diversion($number);
2946             #
2947             # And append to the now-current diversion
2948             #
2949 18         308 $self->impl_appendValue($content);
2950             }
2951             else {
2952 15         275 $self->_remove_diversion($number);
2953             }
2954             }
2955             else {
2956             #
2957             # Treated as name of a file
2958             #
2959 3         88 $self->impl_appendValue( $self->builtin_include($number) );
2960             }
2961             }
2962              
2963 157         857 return '';
2964             }
2965              
2966 1 50   1   2161 method builtin_divnum (@ignored --> Str) {
  1 50   225   2  
  1         137  
  1         1653  
  225         2865  
  225         645  
  225         500  
2967 225         3850 $self->_checkIgnored( 'divnum', @ignored );
2968              
2969 225         3867 return $self->_lastDiversionNumbers_get(-1);
2970             }
2971              
2972 1 50   1   4145 method builtin_len (Undef|Str $string?, @ignored --> Str) {
  1 50   6   3  
  1 50       158  
  1 50       6  
  1 50       3  
  1         211  
  1         1724  
  6         445  
  6         26  
  6         22  
  6         15  
  6         38  
  6         22  
  6         12  
2973 6 50       22 if ( Undef->check($string) ) {
2974 0         0 $self->logger_error( 'too few arguments to builtin %s',
2975             $self->impl_quote('len') );
2976 0         0 return '';
2977             }
2978 6         159 $self->_checkIgnored( 'len', @ignored );
2979              
2980 6   50     25 $string //= '';
2981 6         88 return length($string);
2982             }
2983              
2984 1 50   1   5979 method builtin_index (Undef|Str $string?, Undef|Str $substring?, @ignored --> Str) {
  1 100   7   2  
  1 50       163  
  1 100       6  
  1 100       2  
  1 50       119  
  1 100       6  
  1 50       2  
  1         265  
  1         1717  
  7         588  
  7         37  
  7         33  
  6         13  
  6         41  
  7         30  
  7         29  
  5         12  
  5         25  
  7         30  
  7         18  
2985 7 100       29 if ( Undef->check($string) ) {
2986 1         28 $self->logger_error(
2987             'too few arguments to builtin %s',
2988             $self->impl_quote('index')
2989             );
2990 1         21 return '';
2991             }
2992 6 100       74 if ( Undef->check($substring) ) {
2993 1         35 $self->logger_error(
2994             'too few arguments to builtin %s',
2995             $self->impl_quote('index')
2996             );
2997 1         21 return 0;
2998             }
2999 5         157 $self->_checkIgnored( 'index', @ignored );
3000              
3001 5 50       42 if ( Undef->check($substring) ) {
3002 0         0 $self->logger_warn( '%s: undefined string to search for',
3003             'index', $_ );
3004 0         0 $substring = '';
3005             }
3006 5         167 return index( $string, $substring );
3007             }
3008              
3009 1 50   1   7534 method builtin_regexp (Undef|Str $string?, Undef|Str $regexpString?, Undef|Str $replacement?, @ignored --> Str) {
  1 50   29   2  
  1 50       173  
  1 50       7  
  1 100       2  
  1 50       117  
  1 100       6  
  1 100       2  
  1 50       111  
  1 100       7  
  1 50       2  
  1         407  
  1         1815  
  29         2466  
  29         143  
  29         143  
  29         72  
  29         187  
  29         132  
  29         159  
  28         59  
  28         108  
  29         131  
  29         122  
  16         42  
  16         61  
  29         127  
  29         76  
3010 29 100 66     111 if ( Undef->check($string) || Undef->check($regexpString) ) {
3011 1         35 $self->logger_error(
3012             'too few arguments to builtin %s',
3013             $self->impl_quote('regexp')
3014             );
3015 1         23 return '0';
3016             }
3017              
3018 28         1145 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
3019 28 100       1244 if (!$r->regexp_compile( $self, $self->_regexp_type, $regexpString ) )
3020             {
3021 1         81 return '';
3022             }
3023              
3024 27         1390 $self->_checkIgnored( 'regexp', @ignored );
3025              
3026 27 100       94 if ( Undef->check($replacement) ) {
3027             #
3028             # Expands to the index of first match in string
3029             #
3030 11 100       347 if ( $r->regexp_exec( $self, $string ) >= 0 ) {
3031 7         257 return $r->regexp_lpos_get(0);
3032             }
3033             else {
3034 4         124 return -1;
3035             }
3036             }
3037             else {
3038 16 100       449 if ( $r->regexp_exec( $self, $string ) >= 0 ) {
3039 14         436 return $r->regexp_substitute( $self, $string, $replacement );
3040             }
3041             else {
3042 2         71 return '';
3043             }
3044             }
3045             }
3046              
3047 1 50   1   7299 method builtin_substr (Undef|Str $string?, Undef|Str $from?, Undef|Str $length?, @ignored --> Str) {
  1 50   4   2  
  1 50       177  
  1 50       9  
  1 100       4  
  1 50       127  
  1 100       6  
  1 100       3  
  1 50       110  
  1 100       10  
  1 50       2  
  1         400  
  1         1800  
  4         278  
  4         17  
  4         16  
  4         8  
  4         21  
  4         15  
  4         14  
  3         6  
  3         12  
  4         15  
  4         14  
  1         2  
  1         5  
  4         16  
  4         8  
3048 4 50       13 if ( Undef->check($string) ) {
3049 0         0 $self->logger_error(
3050             'too few arguments to builtin %s',
3051             $self->impl_quote('substr')
3052             );
3053 0         0 return '';
3054             }
3055 4 100       41 if ( Undef->check($from) ) {
3056 1         25 $self->logger_error(
3057             'too few arguments to builtin %s',
3058             $self->impl_quote('substr')
3059             );
3060 1         21 return $string;
3061             }
3062 3         73 $self->_checkIgnored( 'substr', @ignored );
3063              
3064 3 100       11 if ( length($from) <= 0 ) {
3065 1         19 $self->logger_warn( '%s: empty string treated as zero',
3066             'substr' );
3067 1         3 $from = 0;
3068             }
3069              
3070 3 50       24 if ( !PositiveOrZeroInt->check($from) ) {
3071 0         0 $self->logger_error(
3072             '%s: %s: does not look like a positive or zero integer',
3073             'substr', $from );
3074 0         0 return '';
3075             }
3076 3 100       33 if ( Str->check($length) ) {
3077 1 50       11 if ( !Int->check($length) ) {
3078 0         0 $self->logger_error( '%s: %s: does not look like an integer',
3079             'substr', $length );
3080 0         0 return '';
3081             }
3082             }
3083              
3084 3 100       31 return ( !Undef->check($length) )
3085             ? substr( $string, $from, $length )
3086             : substr( $string, $from );
3087             }
3088              
3089 1 50   1   2527 method _expandRanges (Str $range --> Str) {
  1 50   25   3  
  1 50       165  
  1 50       7  
  1 50       2  
  1         415  
  1         2374  
  25         211  
  25         78  
  25         64  
  25         79  
  25         43  
  25         69  
  25         40  
3090 25         47 my $rc = '';
3091 25         82 my @chars = split( //, $range );
3092 25         80 for (
3093             my $from = undef, my $i = 0;
3094             $i <= $#chars;
3095             $from = ord( $chars[ $i++ ] )
3096             )
3097             {
3098 56         86 my $s = $chars[$i];
3099 56 100 100     179 if ( $s eq '-' && defined($from) ) {
3100 26 100       71 my $to = ( ++$i <= $#chars ) ? ord( $chars[$i] ) : undef;
3101 26 100       85 if ( !defined($to) ) {
    100          
3102             #
3103             # Trailing dash
3104             #
3105 1         2 $rc .= '-';
3106 1         4 last;
3107             }
3108             elsif ( $from <= $to ) {
3109 23         57 while ( $from++ < $to ) {
3110 508         926 $rc .= chr($from);
3111             }
3112             }
3113             else {
3114 2         8 while ( --$from >= $to ) {
3115 27         52 $rc .= chr($from);
3116             }
3117             }
3118             }
3119             else {
3120 30         100 $rc .= $chars[$i];
3121             }
3122             }
3123 25         395 return $rc;
3124             }
3125              
3126 1 50   1   7461 method builtin_translit (Undef|Str $string?, Undef|Str $from?, Undef|Str $to?, @ignored --> Str) {
  1 50   16   3  
  1 50       221  
  1 50       8  
  1 50       2  
  1 50       134  
  1 50       7  
  1 100       4  
  1 50       157  
  1 100       7  
  1 50       3  
  1         702  
  1         1847  
  16         1084  
  16         56  
  16         77  
  16         33  
  16         88  
  16         60  
  16         51  
  16         28  
  16         60  
  16         55  
  16         50  
  15         24  
  15         66  
  16         62  
  16         36  
3127 16 50       51 if ( Undef->check($string) ) {
3128 0         0 $self->logger_error(
3129             'too few arguments to builtin %s',
3130             $self->impl_quote('translit')
3131             );
3132 0         0 return '';
3133             }
3134 16 50       176 if ( Undef->check($from) ) {
3135 0         0 $self->logger_error(
3136             'too few arguments to builtin %s',
3137             $self->impl_quote('translit')
3138             );
3139 0         0 return $string;
3140             }
3141 16         444 $self->_checkIgnored( 'translit', @ignored );
3142              
3143 16         42 my $fromLength = length($from);
3144 16 50       54 if ( $fromLength <= 0 ) {
3145 0         0 return '';
3146             }
3147              
3148             #
3149             # We duplicate the algorithm of GNU m4: translit
3150             # is part of M4 official spec, so we cannot use
3151             # perl's tr, which is not stricly equivalent.
3152             # De-facto, we will get GNU behaviour.
3153             #
3154 16   100     73 $to //= '';
3155 16 100       81 if ( index( $to, '-' ) >= 0 ) {
3156 11         197 $to = $self->_expandRanges($to);
3157             }
3158             #
3159             # In case of small $from, let's go to the range algorithm
3160             # anyway.
3161             # GNU m4 implementation is correct doing direct
3162             # transformation if there is only one or two bytes.
3163             # Well, for us, I'd say one of two characters.
3164              
3165 16 100       140 if ( index( $from, '-' ) >= 0 ) {
3166 14         235 $from = $self->_expandRanges($from);
3167             }
3168              
3169 16         123 my %map = ();
3170 16         43 my $toMaxIndice = length($to) - 1;
3171 16         33 my $ito = 0;
3172 16         90 foreach ( split( //, $from ) ) {
3173 306 100       508 if ( !exists( $map{$_} ) ) {
3174 305 100       433 if ( $ito <= $toMaxIndice ) {
3175 277         582 $map{$_} = substr( $to, $ito, 1 );
3176             }
3177             else {
3178 28         58 $map{$_} = '';
3179             }
3180             }
3181 306 100       519 if ( $ito <= $toMaxIndice ) {
3182 278         358 $ito++;
3183             }
3184             }
3185              
3186 16         52 my $rc = '';
3187 16         60 foreach ( split( //, $string ) ) {
3188 129 100       205 if ( exists( $map{$_} ) ) {
3189 47         88 $rc .= $map{$_};
3190             }
3191             else {
3192 82         116 $rc .= $_;
3193             }
3194             }
3195              
3196 16         304 return $rc;
3197             }
3198              
3199             #
3200             # Almost same thing as regexp but with a /g modifier
3201             #
3202 1 50   1   8029 method builtin_patsubst (Undef|Str $string?, Undef|Str $regexpString?, Undef|Str $replacement?, @ignored --> Str) {
  1 50   12   4  
  1 50       180  
  1 50       6  
  1 100       2  
  1 50       160  
  1 100       7  
  1 100       3  
  1 50       128  
  1 100       10  
  1 50       3  
  1         539  
  1         1705  
  12         848  
  12         44  
  12         48  
  12         25  
  12         65  
  12         51  
  12         36  
  11         20  
  11         39  
  12         47  
  12         43  
  9         16  
  9         27  
  12         42  
  12         20  
3203 12 50       35 if ( Undef->check($string) ) {
3204 0         0 $self->logger_error(
3205             'too few arguments to builtin %s',
3206             $self->impl_quote('patsubst')
3207             );
3208 0         0 return '';
3209             }
3210              
3211 12 100       123 if ( Undef->check($regexpString) ) {
3212 1         25 $self->logger_error(
3213             'too few arguments to builtin %s',
3214             $self->impl_quote('patsubst')
3215             );
3216 1         31 return $string;
3217             }
3218              
3219 11         273 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
3220 11 50       406 if (!$r->regexp_compile( $self, $self->_regexp_type, $regexpString ) )
3221             {
3222 0         0 return '';
3223             }
3224              
3225 11         472 $self->_checkIgnored( 'patsubst', @ignored );
3226              
3227             #
3228             # If not supplied, default replacement is deletion
3229             #
3230 11   100     37 $replacement //= '';
3231             #
3232             # Copy of the GNU M4's algorithm
3233             #
3234 11         25 my $offset = 0;
3235 11         32 my $length = length($string);
3236 11         30 my $rc = '';
3237 11         40 while ( $offset <= $length ) {
3238 39         1172 my $matchPos = $r->regexp_exec( $self, $string, $offset );
3239 39 100       427 if ( $matchPos < 0 ) {
3240 8 50       35 if ( $matchPos < -1 ) {
    100          
3241 0         0 $self->logger_error(
3242             'error matching regular expression %s',
3243             $self->impl_quote($regexpString)
3244             );
3245             }
3246             elsif ( $offset < $length ) {
3247 3         9 $rc .= substr( $string, $offset );
3248             }
3249 8         18 last;
3250             }
3251 31 100       82 if ( $matchPos > 0 ) {
3252             #
3253             # Part of the string skipped by regexp_exec
3254             #
3255 23         70 $rc .= substr( $string, $offset, $matchPos - $offset );
3256             }
3257             #
3258             # Do substitution in string:
3259             #
3260 31         513 $rc .= $r->regexp_substitute( $self, $string, $replacement );
3261             #
3262             # Continue to the end of the match
3263             #
3264 31         638 $offset = $r->regexp_rpos_get(0);
3265             #
3266             # If the regexp matched an empty string,
3267             # advance once more
3268             #
3269 31 100       1578 if ( $r->regexp_lpos_get(0) == $offset ) {
3270              
3271 15         567 $rc .= substr( $string, $offset++, 1 );
3272             }
3273             }
3274              
3275 11         194 return $rc;
3276             }
3277              
3278 1 50   1   4573 method builtin_format (Undef|Str $format?, Str @arguments --> Str) {
  1 50   18   4  
  1 50       163  
  1 50       7  
  1 50       2  
  1 50       116  
  1         7  
  1         3  
  1         246  
  1         1715  
  18         1274  
  18         68  
  18         71  
  18         36  
  18         111  
  18         113  
  18         60  
  32         60  
  32         85  
  18         34  
3279 18 50       53 if ( Undef->check($format) ) {
3280 0         0 $self->logger_error(
3281             'too few arguments to builtin %s',
3282             $self->impl_quote('format')
3283             );
3284 0         0 return '';
3285             }
3286 18         194 my $rc = '';
3287             try {
3288 18     18   1009 $rc = sprintf( $format, @arguments );
3289             }
3290             catch {
3291 0     0   0 $self->logger_error( 'format: %s', "$_" );
3292 0         0 return;
3293 18         163 };
3294 18         575 return $rc;
3295             }
3296              
3297 1 50   1   4852 method builtin_incr (Undef|Str $number?, Str @ignored --> Str) {
  1 50   78   4  
  1 50       168  
  1 50       7  
  1 50       3  
  1 0       125  
  1         6  
  1         3  
  1         204  
  1         1730  
  78         5621  
  78         373  
  78         322  
  78         160  
  78         465  
  78         309  
  78         235  
  0         0  
  0         0  
  78         147  
3298 78         1616 $self->_checkIgnored( 'incr', @ignored );
3299 78   50     213 $number //= '';
3300 78 100       316 if ( length($number) <= 0 ) {
3301 1         20 $self->logger_error( 'empty string treated as 0 in builtin %s',
3302             $self->impl_quote('incr') );
3303 1         4 $number = 0;
3304             }
3305 78 50       432 if ( !Int->check($number) ) {
3306 0         0 $self->logger_error(
3307             '%s: %s: does not look like an integer',
3308             $self->impl_quote('incr'),
3309             $self->impl_quote($number)
3310             );
3311 0         0 return '';
3312             }
3313 78         1000 my $rc = '';
3314 78 50       1453 if ( $self->_integer_type eq 'native' ) {
3315 1     1   495 use integer;
  1         14  
  1         5  
3316 0         0 $rc = $number + 1;
3317             }
3318             else {
3319 78         2381 $rc = $self->builtin_eval("$number + 1");
3320             }
3321 78         1930 return $rc;
3322             }
3323              
3324 1 50   1   4721 method builtin_decr (Undef|Str $number?, Str @ignored --> Str) {
  1 50   21   3  
  1 50       174  
  1 50       7  
  1 50       2  
  1 0       122  
  1         5  
  1         4  
  1         220  
  1         1765  
  21         1724  
  21         107  
  21         105  
  21         46  
  21         123  
  21         85  
  21         69  
  0         0  
  0         0  
  21         48  
3325 21         438 $self->_checkIgnored( 'decr', @ignored );
3326 21   50     66 $number //= '';
3327 21 100       98 if ( length($number) <= 0 ) {
3328 1         18 $self->logger_error( 'empty string treated as 0 in builtin %s',
3329             $self->impl_quote('decr') );
3330 1         4 $number = 0;
3331             }
3332 21 50       120 if ( !Int->check($number) ) {
3333 0         0 $self->logger_error(
3334             '%s: %s: does not look like an integer',
3335             $self->impl_quote('decr'),
3336             $self->impl_quote($number)
3337             );
3338 0         0 return '';
3339             }
3340 21         286 my $rc = '';
3341 21 50       451 if ( $self->_integer_type eq 'native' ) {
3342 1     1   7 use integer;
  1         2  
  1         4  
3343 0         0 $rc = $number - 1;
3344             }
3345             else {
3346 21         690 $rc = $self->builtin_eval("$number - 1");
3347             }
3348 21         616 return $rc;
3349             }
3350              
3351 1 50   1   8068 method builtin_eval (Undef|Str $expression?, Undef|Str $radix?, Undef|Str $width?, Str @ignored --> Str) {
  1 50   171   3  
  1 50       165  
  1 50       7  
  1 100       2  
  1 50       115  
  1 100       6  
  1 100       2  
  1 50       113  
  1 100       5  
  1 50       3  
  1 0       106  
  1         7  
  1         2  
  1         967  
  1         1766  
  171         7619  
  171         778  
  171         807  
  171         330  
  171         1025  
  171         698  
  171         604  
  10         25  
  10         58  
  171         590  
  171         601  
  5         14  
  5         30  
  171         633  
  171         518  
  0         0  
  0         0  
  171         378  
3352 171 50       601 if ( Undef->check($expression) ) {
3353 0         0 $self->logger_error(
3354             'too few arguments to builtin %s',
3355             $self->impl_quote('decr')
3356             );
3357 0         0 return '';
3358             }
3359 171         5322 $self->_checkIgnored( 'eval', @ignored );
3360              
3361 171 50       462 if ( Undef->check($expression) ) {
3362 0         0 $self->logger_error( '%s: empty string treated as zero',
3363             $self->impl_quote('eval') );
3364 0         0 return 0;
3365             }
3366             #
3367             # Validate radix
3368             #
3369 171 100 100     1723 if ( Undef->check($radix) || length($radix) <= 0 ) {
3370 163         1560 $radix = 10;
3371             }
3372 171 50       1011 if ( !PositiveInt->check($radix) ) {
3373 0         0 $self->logger_error(
3374             '%s: %s: does not look like a positive integer',
3375             $self->impl_quote('eval'),
3376             $self->impl_quote($radix)
3377             );
3378 0         0 return '';
3379             }
3380 171 100 66     2482 if ( $radix < 1 || $radix > 36 ) {
3381 1         20 $self->logger_error(
3382             '%s: %s: should be in the range [1..36]',
3383             $self->impl_quote('eval'),
3384             $self->impl_quote($radix)
3385             );
3386 1         20 return '';
3387             }
3388             #
3389             # Validate width
3390             #
3391 170 100 66     542 if ( Undef->check($width) || length($width) <= 0 ) {
3392 165         1625 $width = 1;
3393             }
3394 170 100       989 if ( !PositiveOrZeroInt->check($width) ) {
3395 1         27 $self->logger_error(
3396             '%s: %s: width does not look like a positive or zero integer',
3397             $self->impl_quote('eval'), $self->impl_quote($width)
3398             );
3399 1         22 return '';
3400             }
3401             #
3402             # Check expression
3403             #
3404 169 100       1924 if ( length($expression) <= 0 ) {
3405 1         21 $self->logger_error( '%s: empty string treated as zero',
3406             $self->impl_quote('eval') );
3407 1         4 $expression = 0;
3408             }
3409             #
3410             # Eval
3411             #
3412 169         375 my $rc = '';
3413             #
3414             # For $r->value() optimisations: outside of the try {} block
3415             # otherwise state optimisation seems to be off
3416             #
3417 169         327 state $registrations = undef;
3418             try {
3419 169     169   12014 local $MarpaX::Languages::M4::Impl::Default::INTEGER_BITS
3420             = $self->_integer_bits;
3421 169         2605 local $MarpaX::Languages::M4::Impl::Default::SELF = $self;
3422             #
3423             # Calling parse method will always resolve the actions to the same value...
3424             # As we do in Parser, use our Marpa hack to avoid such repetition
3425             #
3426 169         1383 my $r = Marpa::R2::Scanless::R->new(
3427             { grammar => $EVAL_G,
3428             semantics_package => 'MarpaX::Languages::M4::Impl::Default::Eval'
3429             # trace_terminals => 1,
3430             # trace_values => 1
3431             }
3432             );
3433 169         58653 $r->read(\$expression);
3434 168         41480 my $ambiguous_status = $r->ambiguous;
3435 168 50       13131 if ($ambiguous_status) {
3436 0         0 Marpa::R2::exception( "Eval is ambiguous (ambiguous status is" . $ambiguous_status . "): $expression\n");
3437             }
3438              
3439 168 100       647 if (defined($registrations)) {
3440 167         851 $r->registrations($registrations);
3441             }
3442 168         836 my $valuep = $r->value;
3443 162 100       7508 if (! defined($registrations)) {
3444 1         6 $registrations = $r->registrations();
3445             }
3446 162 50       585 if (! defined($valuep)) {
3447 0         0 Marpa::R2::exception( "No eval parse value: $expression\n");
3448             }
3449             $rc = MarpaX::Languages::M4::Impl::Default::BaseConversion
3450 162         387 ->bitvector_to_base( $radix, ${$valuep}, $width );
  162         4925  
3451             }
3452             catch {
3453             #
3454             # Marpa::R2::Context::bail() is adding
3455             # something like e.g.:
3456             # User bailed at line 37 in file "xxx"
3457             # we strip this line if any
3458             #
3459 7     7   3504 $_ =~ s/^User bailed.*?\n//;
3460 7         194 $self->logger_error( '%s: %s', $self->impl_quote('eval'), "$_" );
3461 7         60 return;
3462 169         2073 };
3463              
3464 169         12100 return $rc;
3465             }
3466              
3467 1 50   1   6598 method _syscmd (Str $macroName, Bool $appendValue, Undef|Str $command?, Str @ignored --> Str) {
  1 50   8   2  
  1 50       187  
  1 50       11  
  1 50       2  
  1 50       123  
  1 50       6  
  1 50       5  
  1 50       101  
  1 50       6  
  1 50       3  
  1 50       104  
  1 0       6  
  1         2  
  1         626  
  1         1846  
  8         369  
  8         46  
  8         50  
  8         41  
  8         29  
  8         49  
  8         53  
  8         40  
  8         20  
  8         45  
  8         52  
  8         54  
  8         27  
  8         54  
  8         54  
  8         34  
  0         0  
  0         0  
  8         22  
3468 8 50       43 if ( Undef->check($command) ) {
3469 0         0 $self->logger_error(
3470             'too few arguments to builtin %s',
3471             $self->impl_quote($macroName)
3472             );
3473 0         0 return '';
3474             }
3475 8         380 $self->_checkIgnored( $macroName, @ignored );
3476              
3477 8   50     60 $command //= '';
3478 8 50       63 if ( length($command) > 0 ) {
3479 8         34 my ( $stdout, $stderr, $success, $exitCode );
3480 8         55 my $executed = false;
3481             try {
3482 8     8   1174 ( $stdout, $stderr, $success, $exitCode )
3483             = capture_exec($command);
3484             }
3485             catch {
3486 0     0   0 $self->logger_error( '%s: %s',
3487             $self->impl_quote($macroName), "$_" );
3488 0         0 return;
3489             }
3490             finally {
3491 8 50   8   254739 if ( !$@ ) {
3492 8         153 $executed = true;
3493             }
3494 8         181 };
3495 8 50       752 if ($executed) {
3496 8         886 $self->_lastSysExitCode( $exitCode >> 8 );
3497 8 50       970 if ( $self->_cmdtounix ) {
3498 8         193 $stderr =~ s/\R/\n/g;
3499 8         47 $stdout =~ s/\R/\n/g;
3500             }
3501 8 50       76 if ( length($stderr) > 0 ) {
3502 0         0 $self->logger_error( '%s', $stderr );
3503             }
3504 8 100       58 if ($appendValue) {
3505 4         162 $self->impl_appendValue($stdout);
3506 4         214 return '';
3507             }
3508             else {
3509 4         205 return $stdout;
3510             }
3511             }
3512             }
3513 0         0 return '';
3514             }
3515              
3516 1 50   1   4775 method builtin_syscmd (Undef|Str $command?, Str @ignored --> Str) {
  1 50   4   4  
  1 50       165  
  1 50       11  
  1 50       3  
  1 0       125  
  1         7  
  1         3  
  1         115  
  1         1756  
  4         463  
  4         25  
  4         19  
  4         12  
  4         30  
  4         31  
  4         15  
  0         0  
  0         0  
  4         10  
3517 4         31 return $self->_syscmd( 'syscmd', true, $command, @ignored );
3518             }
3519              
3520 1 50   1   4784 method builtin_esyscmd (Undef|Str $command?, Str @ignored --> Str) {
  1 50   4   3  
  1 50       150  
  1 50       11  
  1 50       4  
  1 0       192  
  1         8  
  1         2  
  1         116  
  1         1787  
  4         495  
  4         24  
  4         26  
  4         17  
  4         37  
  4         34  
  4         26  
  0         0  
  0         0  
  4         14  
3521 4         32 return $self->_syscmd( 'esyscmd', false, $command, @ignored );
3522             }
3523              
3524 1 50   1   2770 method builtin_sysval (Str @ignored --> Str) {
  1 50   7   3  
  1 0       143  
  1         6  
  1         3  
  1         103  
  1         1719  
  7         995  
  7         49  
  7         36  
  0         0  
  0         0  
  7         27  
3525 7         268 $self->_checkIgnored( 'sysval', @ignored );
3526              
3527 7         217 return $self->_lastSysExitCode;
3528             }
3529              
3530 1 50   1   4910 method _mkstemp (Str $macro, Undef|Str $template?, Str @ignored --> Str) {
  1 50   2   3  
  1 50       166  
  1 50       7  
  1 50       2  
  1 50       111  
  1 50       6  
  1 50       2  
  1 50       105  
  1 0       6  
  1         4  
  1         405  
  1         1764  
  2         41  
  2         14  
  2         14  
  2         13  
  2         7  
  2         11  
  2         12  
  2         8  
  2         7  
  2         18  
  2         11  
  2         7  
  0         0  
  0         0  
  2         8  
3531 2 50       10 if ( Undef->check($template) ) {
3532 0         0 $self->logger_error(
3533             'too few arguments to builtin %s',
3534             $self->impl_quote($macro)
3535             );
3536 0         0 return '';
3537             }
3538 2         76 $self->_checkIgnored( $macro, @ignored );
3539              
3540 2   50     13 $template //= '';
3541 2         19 while ( !( $template =~ /XXXXXX$/ ) ) {
3542 6         23 $template .= 'X';
3543             }
3544 2         8 my $tmp = '';
3545             try {
3546 2     2   159 $tmp = File::Temp->new( TEMPLATE => $template );
3547             }
3548             catch {
3549 0     0   0 $self->logger_error( '%s: %s', $macro, "$_" );
3550 0         0 return;
3551 2         29 };
3552              
3553 2         1220 return $self->impl_quote( $tmp->filename );
3554             }
3555              
3556 1 50   1   2329 method builtin_mkstemp (Str @args --> Str) {
  1 50   1   30  
  1 50       151  
  1         9  
  1         3  
  1         96  
  1         1788  
  1         90  
  1         8  
  1         4  
  1         1  
  1         5  
  1         1  
3557 1         21 return $self->_mkstemp( 'mkstemp', @args );
3558             }
3559              
3560 1 50   1   2245 method builtin_maketemp (Str @args --> Str) {
  1 50   1   3  
  1 50       131  
  1         7  
  1         2  
  1         116  
  1         1752  
  1         131  
  1         11  
  1         7  
  1         6  
  1         14  
  1         5  
3561 1         50 return $self->_mkstemp( 'maketemp', @args );
3562             }
3563              
3564 1 50   1   2260 method builtin_errprint (Str @args --> Str) {
  1 50   5   3  
  1 50       155  
  1         11  
  1         4  
  1         158  
  1         1744  
  5         575  
  5         45  
  5         24  
  6         17  
  6         41  
  5         15  
3565             #
3566             # debugfile is IGNORED
3567             #
3568 5         150 my $oldDebugfile = $self->_debugfile;
3569              
3570 5         220 $self->_set__debugfile(undef);
3571 5         331 $self->logger_error( '%s', join( ' ', @args ) );
3572 5         174 $self->_set__debugfile($oldDebugfile);
3573              
3574 5         300 return '';
3575             }
3576              
3577 1 50   1   2282 method builtin___file__ (Str @ignored --> Str) {
  1 50   2   3  
  1 0       130  
  1         7  
  1         2  
  1         97  
  1         1749  
  2         152  
  2         10  
  2         7  
  0         0  
  0         0  
  2         4  
3578 2         40 $self->_checkIgnored( '__file__', @ignored );
3579 2         40 return $self->__file__;
3580             }
3581              
3582 1 50   1   2241 method builtin___line__ (Str @ignored --> Str) {
  1 50   2   3  
  1 0       126  
  1         7  
  1         7  
  1         99  
  1         1746  
  2         146  
  2         11  
  2         10  
  0         0  
  0         0  
  2         8  
3583 2         54 $self->_checkIgnored( '__line__', @ignored );
3584 2         40 return $self->__line__;
3585             }
3586              
3587 1 50   1   2292 method builtin___program__ (Str @ignored --> Str) {
  1 50   2   3  
  1 0       123  
  1         6  
  1         2  
  1         125  
  1         1704  
  2         155  
  2         9  
  2         9  
  0         0  
  0         0  
  2         4  
3588 2         56 $self->_checkIgnored( '__program__', @ignored );
3589 2         58 return $self->__program__;
3590             }
3591             #
3592             # $0 is replaced by $name
3593             # arguments are in the form $1, $2, etc...
3594             # mapped to $_[1], $_[2], etc...
3595             # $# is the number of arguments
3596             # $* is all arguments separated by comma
3597             # $@ is all quoted arguments separated by comma
3598             #
3599 1 50   1   3495 method _expansion2CodeRef (Str $name, Str $expansion --> CodeRef) {
  1 50   370   3  
  1 50       193  
  1 50       8  
  1 50       2  
  1 50       121  
  1 50       6  
  1 50       2  
  1         918  
  1         1779  
  370         4468  
  370         1241  
  370         1210  
  370         1261  
  370         1040  
  370         1204  
  370         1396  
  370         1087  
  370         703  
  370         1220  
  370         668  
3600             #
3601             # Check macro content
3602             #
3603 370 100       6737 if ( $self->_warn_macro_sequence ) {
3604 2         64 my $r = $self->_warn_macro_sequence_regexp;
3605 2         112 my $offset = 0;
3606 2         7 my $len = length($expansion);
3607 2         38 while ( $offset
3608             = $r->regexp_exec( $self, $expansion, $offset ) >= 0 )
3609             {
3610             #
3611             # Skip empty matches
3612             #
3613 2 50       60 if ( $r->regexp_lpos_get(0) == $r->regexp_rpos_get(0) ) {
3614 0         0 $offset++;
3615             }
3616             else {
3617 2         223 $offset = $r->regexp_rpos_get(0);
3618 2         116 $self->logger_warn(
3619             'Definition of %s contains sequence %s',
3620             $self->impl_quote($name),
3621             $self->impl_quote(
3622             substr(
3623             $expansion,
3624             $r->regexp_lpos_get(0),
3625             $r->regexp_rpos_get(0)
3626             - $r->regexp_lpos_get(0)
3627             )
3628             )
3629             );
3630             }
3631             }
3632 0 0       0 if ( $offset < -1 ) {
3633 0         0 $self->logger_warn(
3634             'error checking --warn-macro-sequence for macro %s',
3635             $self->impl_quote($name) );
3636             }
3637             }
3638              
3639 368         5907 my $maxArgumentIndice = -1;
3640 368         829 my %wantedArgumentIndice = ();
3641 368         1115 my $newExpansion = quotemeta($expansion);
3642             #
3643             # Arguments and $0
3644             #
3645 368         1501 $newExpansion =~ s/\\\$([0-9]+)/
3646             {
3647             #
3648             # Writen like this to show that this is a BLOCK on the right-side of eval
3649             #
3650 276         450 my $dollarOne = substr($newExpansion, $-[1], $+[1] - $-[1]);
  276         1594  
3651 276 100       858 if ($dollarOne > $maxArgumentIndice) {
3652 124         268 $maxArgumentIndice = $dollarOne;
3653             }
3654 276 100       558 if ($dollarOne == 0) {
3655             # "\$0";
3656 40         250 "\" . \"" . quotemeta($name) . "\" . \"";
3657             } else {
3658 236         538 $wantedArgumentIndice{$dollarOne}++;
3659 236         1096 "\" . " . "\$_\[$dollarOne\]" . " . \"";
3660             }
3661             }/eg;
3662 368         956 my $prepareArguments = "\n";
3663             #
3664             # We use unused argument indices from now on.
3665             #
3666             # Number of arguments.
3667             #
3668 368 100       1379 if ( $newExpansion =~ s/\\\$\\\#/" . \$nbArgs . "/g ) {
3669 25         70 $prepareArguments
3670             .= "\tmy \$nbArgs = \$#_; # \$_[0] is \$self\n";
3671             }
3672             #
3673             # Arguments expansion, unquoted.
3674             #
3675 368 100       1285 if ( $newExpansion =~ s/\\\$\\\*/" . \$listArgs . "/g ) {
3676 15         44 $prepareArguments
3677             .= "\tmy \$listArgs = join(',', map {\$_[\$_] // ''} (1..\$#_));\n";
3678             }
3679             #
3680             # Arguments expansion, quoted.
3681             #
3682 368 100       1386 if ( $newExpansion =~ s/\\\$\\\@/" . \$listArgsQuoted . "/g ) {
3683 46         114 $prepareArguments
3684             .= "\tmy \$listArgsQuoted = join(',', map {\$_[0]->impl_quote(\$_[\$_])} (1..\$#_));\n";
3685             }
3686             #
3687             # Take care: a macro can very well try to access
3688             # something outside of @args
3689             # We do this only NOW, because the //= will eventually
3690             # increase @_
3691             #
3692 368 100       1172 if (%wantedArgumentIndice) {
3693 78         154 $prepareArguments .= "\n";
3694 78         520 foreach ( sort { $a <=> $b } keys %wantedArgumentIndice ) {
  61         220  
3695 132         302 $prepareArguments .= "\t\$_[$_] //= '';\n";
3696             }
3697             }
3698 368         881 my $stub;
3699             my $error;
3700             #
3701             # If it fails, our fault
3702             #
3703 368         1544 my $stubSource = <<"STUB";
3704             sub {
3705             $prepareArguments
3706             \treturn "$newExpansion";
3707             }
3708             STUB
3709 368         71914 my $codeRef = eval "$stubSource";
3710 368 50       2347 if ($@) {
3711             #
3712             # Explicitely logged as an internal error, because if I made
3713             # no error in this routine, this must never happen.
3714             #
3715 0         0 $self->logger_error( 'Internal: %s', $@ );
3716             }
3717 368         7606 return $codeRef;
3718             }
3719              
3720 1 0   1   2031 method _issue_expect_message (Str $expected) {
  1 0   0   2  
  1 0       145  
  1 0       6  
  1 0       3  
  1         164  
  1         2213  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
3721 0 0       0 if ( $expected eq "\n" ) {
3722 0         0 $self->logger_error('expecting line feed in frozen file');
3723             }
3724             else {
3725 0         0 $self->logger_error(
3726             sprintf( 'expecting character %s in frozen file',
3727             $self->impl_quote($expected) )
3728             );
3729             }
3730             }
3731              
3732 1 50   1   1442 method impl_freezeState (--> Bool) {
  1 50   142   2  
  1         317  
  1         187  
  142         1731  
  142         525  
  142         310  
3733 142 100       787 if ( !$self->_stateFreezed ) {
3734 140 50       2645 if ( length( $self->freeze_state ) > 0 ) {
3735             try {
3736 0     0   0 my $file = $self->freeze_state;
3737             my $fh = IO::File->new(
3738             $ENV{M4_ENCODE_LOCALE}
3739 0   0     0 ? encode( locale_fs => $file )
3740             : $file,
3741             'w'
3742             )
3743             || die "$file: $!";
3744 0 0       0 if ( $ENV{M4_ENCODE_LOCALE} ) {
3745 0         0 binmode( $fh, ':encoding(locale)' );
3746             }
3747             else {
3748 0         0 binmode($fh);
3749             }
3750              
3751 0         0 my $CURRENTVERSION;
3752             {
3753             #
3754             # Because $VERSION is generated by dzil, not available in dev. tree
3755             #
3756 1     1   8 no strict 'vars';
  1         2  
  1         650  
  0         0  
3757 0         0 $CURRENTVERSION = $VERSION;
3758             }
3759 0   0     0 $CURRENTVERSION ||= 'dev';
3760              
3761 0         0 $fh->print(
3762             sprintf(
3763             "# This is a frozen state file generated by %s version %s\n",
3764             __PACKAGE__, $CURRENTVERSION
3765             )
3766             );
3767 0         0 $fh->print("V1\n");
3768             #
3769             # Dump quote delimiters
3770             #
3771 0 0 0     0 if ( $self->_quote_start ne $DEFAULT_QUOTE_START
3772             || $self->_quote_end ne $DEFAULT_QUOTE_END )
3773             {
3774 0         0 $fh->print(
3775             sprintf( "Q%d,%d\n",
3776             length( $self->_quote_start ),
3777             length( $self->_quote_end ) )
3778             );
3779 0         0 $fh->print( $self->_quote_start );
3780 0         0 $fh->print( $self->_quote_end );
3781 0         0 $fh->print("\n");
3782             }
3783             #
3784             # Dump comment delimiters
3785             #
3786 0 0 0     0 if ( $self->_comment_start ne $DEFAULT_COMMENT_START
3787             || $self->_comment_end ne $DEFAULT_COMMENT_END )
3788             {
3789 0         0 $fh->print(
3790             sprintf( "Q%d,%d\n",
3791             length( $self->_comment_start ),
3792             length( $self->_comment_end ) )
3793             );
3794 0         0 $fh->print( $self->_comment_start );
3795 0         0 $fh->print( $self->_comment_end );
3796 0         0 $fh->print("\n");
3797             }
3798             #
3799             # Dump all symbols, for each of them do
3800             # it in reverse order until builtin is reached
3801             #
3802 0         0 foreach ( $self->_macros_keys ) {
3803 0         0 foreach (
3804             reverse(
3805             $self->_macros_get($_)->macros_elements
3806             )
3807             )
3808             {
3809 0         0 my $name = $_->macro_name;
3810 0         0 my $expansion = $_->macro_expansion;
3811             #
3812             # Expansion is either Str or M4Macro
3813             #
3814 0 0       0 if ( $_->macro_isBuiltin ) {
3815 0         0 my $builtinName = $expansion->macro_name;
3816 0         0 my $F = sprintf( "F%d,%d",
3817             length($name), length($builtinName) );
3818 0         0 $fh->print("$F\n$name$builtinName\n");
3819             }
3820             else {
3821 0         0 my $T = sprintf( "T%d,%d",
3822             length($name), length($expansion) );
3823 0         0 $fh->print("$T\n$name$expansion\n");
3824             }
3825             }
3826             }
3827 0         0 $fh->print("# End of frozen state file\n");
3828 0         0 $fh->close;
3829             }
3830             catch {
3831 0     0   0 $self->logger_error( 'failed to freeze state: %s', "$_" );
3832 0         0 return;
3833 0         0 };
3834             }
3835 140         1707 $self->_set__stateFreezed(true);
3836             }
3837 142         7251 return true;
3838             }
3839              
3840 1 0   1   1967 method impl_reloadState (--> Bool) {
  1 0   0   4  
  1         2799  
  1         2107  
  0         0  
  0         0  
  0         0  
3841 0 0       0 if ( !$self->_stateReloaded ) {
3842 0 0       0 if ( length( $self->reload_state ) > 0 ) {
3843             try {
3844 0     0   0 my $content;
3845              
3846 0         0 my $file = $self->reload_state;
3847 0         0 $self->impl_parseIncrementalFile( $file, false, false,
3848             \$content );
3849 0         0 my $fh = IO::Scalar->new( \$content );
3850             #
3851             # This is a copy of m4-1.4.17 algorithm
3852             #
3853 0         0 my $character;
3854             my $operation;
3855 0         0 my $advance_line = true;
3856 0         0 my $current_line = 0;
3857 0         0 my @number = ( undef, undef );
3858 0         0 my @string = ( undef, undef );
3859              
3860             my $GET_CHARACTER = sub {
3861 0         0 my ($self) = @_;
3862              
3863 0 0       0 if ($advance_line) {
3864 0         0 $current_line++;
3865 0         0 $advance_line = false;
3866             }
3867 0         0 $character = $fh->getc();
3868 0 0       0 if ( $character eq "\n" ) {
3869 0         0 $advance_line = false;
3870             }
3871 0         0 };
3872             my $GET_NUMBER = sub {
3873             #
3874             # AllowNeg is not used. We let perl croak if there i an overflow
3875             #
3876 0         0 my ( $self, $allowneg ) = @_;
3877 0         0 my $n = 0;
3878 0         0 while ( $character =~ /[[:digit:]]/ ) {
3879 0         0 $n = 10 * $n + $character;
3880 0         0 $self->$GET_CHARACTER();
3881             }
3882 0         0 return $n;
3883 0         0 };
3884             my $VALIDATE = sub {
3885 0         0 my ( $self, $expected ) = @_;
3886              
3887 0 0       0 if ( $character ne $expected ) {
3888 0         0 $self->_issue_expect_message($expected);
3889             }
3890 0         0 };
3891             my $GET_DIRECTIVE = sub {
3892 0         0 my ($self) = @_;
3893              
3894 0         0 do {
3895 0         0 $self->$GET_CHARACTER();
3896 0 0       0 if ( $character eq '#' ) {
3897 0   0     0 while ( !$fh->eof() && $character ne "\n" ) {
3898 0         0 $self->$GET_CHARACTER();
3899             }
3900 0         0 $self->$VALIDATE("\n");
3901             }
3902             } while ( $character eq "\n" );
3903 0         0 };
3904             my $GET_STRING = sub {
3905 0         0 my ( $self, $i ) = @_;
3906              
3907 0         0 $string[$i] = '';
3908 0 0 0     0 if ( $number[$i] > 0
3909             && !$fh->read( $string[$i], $number[$i] ) )
3910             {
3911 0         0 $self->impl_raiseException(
3912             'premature end of frozen file');
3913             }
3914 0         0 $current_line += $string[$i] =~ tr/\n//;
3915 0         0 };
3916              
3917 0         0 $self->$GET_DIRECTIVE();
3918 0         0 $self->$VALIDATE('V');
3919 0         0 $self->$GET_CHARACTER();
3920 0         0 $number[0] = $self->$GET_NUMBER(false);
3921 0 0       0 if ( $number[0] > 1 ) {
    0          
3922 0         0 die sprintf(
3923             'frozen file version %d greater than max supported of 1',
3924             $number[0] );
3925             }
3926             elsif ( $number[0] < 1 ) {
3927 0         0 die
3928             'ill-formed frozen file, version directive expected';
3929             }
3930 0         0 $self->$VALIDATE("\n");
3931              
3932 0         0 $self->$GET_DIRECTIVE();
3933 0         0 while ( !$fh->eof() ) {
3934 0 0 0     0 if ( $character eq 'C'
      0        
      0        
      0        
3935             || $character eq 'D'
3936             || $character eq 'F'
3937             || $character eq 'T'
3938             || $character eq 'Q' )
3939             {
3940 0         0 $operation = $character;
3941 0         0 $self->$GET_CHARACTER();
3942              
3943             # Get string lengths. Accept a negative diversion number
3944              
3945 0 0 0     0 if ( $operation eq 'D' && $character eq '-' ) {
3946 0         0 $self->$GET_CHARACTER();
3947 0         0 $number[0] = -$self->$GET_NUMBER(true);
3948             }
3949             else {
3950 0         0 $number[0] = $self->$GET_NUMBER(false);
3951             }
3952 0         0 $self->$VALIDATE(',');
3953 0         0 $self->$GET_CHARACTER();
3954 0         0 $number[1] = $self->$GET_NUMBER(false);
3955 0         0 $self->$VALIDATE("\n");
3956 0 0       0 if ( $operation ne 'D' ) {
3957 0         0 $self->$GET_STRING(0);
3958             }
3959 0         0 $self->$GET_STRING(1);
3960 0         0 $self->$GET_CHARACTER();
3961 0         0 $self->$VALIDATE("\n");
3962              
3963 0 0       0 if ( $operation eq 'C' ) {
    0          
    0          
    0          
    0          
3964 0         0 $self->builtin_changecom( $string[0],
3965             $string[1] );
3966             }
3967             elsif ( $operation eq 'D' ) {
3968 0         0 $self->builtin_divert( $number[0] );
3969 0 0       0 if ( $number[1] > 0 ) {
3970 0         0 $self->impl_appendValue( $string[1] );
3971             }
3972             }
3973             elsif ( $operation eq 'F' ) {
3974 0 0       0 if ( $self->_builtins_exists( $string[1] ) ) {
3975 0         0 my $macro
3976             = $self->_builtins_get( $string[1] );
3977 0         0 $self->builtin_pushdef( $string[0],
3978             $macro );
3979             }
3980             #
3981             # Failure is silent
3982             #
3983             }
3984             elsif ( $operation eq 'T' ) {
3985 0         0 $self->builtin_pushdef( $string[0],
3986             $string[1] );
3987             }
3988             elsif ( $operation eq 'Q' ) {
3989 0         0 $self->builtin_changequote( $string[0],
3990             $string[1] );
3991             }
3992             else {
3993             # Cannot happen
3994             }
3995             }
3996             else {
3997 0         0 die 'ill-formed frozen file';
3998             }
3999 0         0 $self->$GET_DIRECTIVE();
4000             }
4001             }
4002             catch {
4003 0     0   0 $self->logger_error( 'failed to reload state: %s', "$_" );
4004 0         0 return;
4005 0         0 };
4006             }
4007 0         0 $self->_set__stateReloaded(true);
4008             }
4009              
4010 0         0 return true;
4011             }
4012              
4013 1 50 33 1   13191 method impl_parseIncrementalFile (Str $file, Bool $silent?, Bool $parse?, Ref['SCALAR'] $contentp? --> ConsumerOf[M4Impl]) {
  1 50   29   4  
  1 50       343  
  1 50       11  
  1 50       10  
  1 50       229  
  1 50       11  
  1 50       4  
  1 50       184  
  1 50       10  
  1 50       4  
  1 50       178  
  1 50       10  
  1 50       4  
  1 50       2988  
  1         2032  
  29         1000  
  29         103  
  29         133  
  29         131  
  29         122  
  29         54  
  29         119  
  29         110  
  29         100  
  29         59  
  29         108  
  29         106  
  29         109  
  29         51  
  29         109  
  29         114  
  29         100  
  29         54  
  29         239  
  29         67  
4014 29   33     87 $silent //= false;
4015 29   33     103 $parse //= true;
4016              
4017             my $uni_file
4018 29 50       128 = $ENV{M4_ENCODE_LOCALE} ? decode( locale => $file ) : $file;
4019              
4020 29 50       104 if ( $uni_file ne '-' ) {
4021 29         50 my $fh;
4022             try {
4023             $fh = IO::File->new(
4024             $ENV{M4_ENCODE_LOCALE}
4025 29   50 29   1735 ? encode( locale_fs => $uni_file )
4026             : $uni_file,
4027             'r'
4028             )
4029             || die $!;
4030 29 50       3822 if ( $ENV{M4_ENCODE_LOCALE} ) {
4031 0         0 binmode( $fh, ':encoding(locale)' );
4032             }
4033             }
4034             catch {
4035 0 0   0   0 if ( !$silent ) {
4036 0         0 $self->logger_error( '%s: %s', $file, "$_" );
4037             }
4038 0         0 return;
4039 29         370 };
4040              
4041 29 50       595 if ( !Undef->check($fh) ) {
4042 29         1036 $self->_set__nbInputProcessed( $self->_nbInputProcessed + 1 );
4043              
4044 29         1785 $self->_set___file__( $self->impl_quote($file) );
4045 29         3089 $self->_set___line__(0);
4046              
4047 29 50       1538 if ( $self->_canDebug('i') ) {
4048 0         0 $self->logger_debug( 'input read from %s', $file );
4049             }
4050 29         3297 $self->_set__eof(true);
4051 29         1412 my $content;
4052             try {
4053 29     29   1320 $content = do { local $/; <$fh>; };
  29         135  
  29         917  
4054             }
4055             catch {
4056 0 0   0   0 if ( !$silent ) {
4057 0         0 $self->logger_warn( '%s: %s', $file, "$_" );
4058             }
4059 0         0 return;
4060 29         299 };
4061             try {
4062 29     29   1138 $fh->close;
4063             }
4064             catch {
4065 0 0   0   0 if ( !$silent ) {
4066 0         0 $self->logger_warn( '%s: %s', $file, "$_" );
4067             }
4068 0         0 return;
4069 29         619 };
4070 29 50       1002 if ( !Undef->check($content) ) {
4071 29 50       1053 if ( $self->_inctounix ) {
4072 29         641 $content =~ s/\R/\n/g;
4073             }
4074             }
4075 29 50       127 if ( !Undef->check($contentp) ) {
4076 29         267 ${$contentp} = $content;
  29         65  
4077             }
4078 29 50       87 if ($parse) {
4079 0         0 $self->impl_parseIncremental($content);
4080             }
4081 29 50       500 if ( $self->_canDebug('i') ) {
4082 0         0 $self->logger_debug( '%s: input exhausted', $file );
4083             }
4084             try {
4085 29     29   1203 $fh->close;
4086             }
4087             catch {
4088 0 0   0   0 if ( !$silent ) {
4089 0         0 $self->logger_warn( '%s', "$_" );
4090             }
4091 0         0 return;
4092 29         3609 };
4093             }
4094             }
4095             else {
4096 0         0 my $fh;
4097 0 0       0 if ( !open( $fh, '<&STDIN' ) ) {
4098 0 0       0 if ( !$silent ) {
4099 0         0 $self->logger_error( 'Failed to duplicate STDIN: %s',
4100             $! );
4101             }
4102             }
4103             else {
4104 0 0       0 if ( $ENV{M4_ENCODE_LOCALE} ) {
4105 0 0       0 if ( is_interactive($fh) ) {
4106 0         0 binmode( $fh, ':encoding(console_in)' );
4107             }
4108             else {
4109 0         0 binmode( $fh, ':encoding(locale)' );
4110             }
4111             }
4112 0         0 $self->_set___file__( $self->impl_quote('stdin') );
4113 0         0 $self->_set___line__(0);
4114              
4115 0         0 $self->_set__nbInputProcessed( $self->_nbInputProcessed + 1 );
4116              
4117 0 0       0 if ( $self->_canDebug('i') ) {
4118 0         0 $self->logger_debug('input read from stdin');
4119             }
4120 0         0 $self->_set__eof(false);
4121 0 0 0     0 if ( $parse && is_interactive($fh) ) {
4122 0         0 $self->_dumpCurrent();
4123             }
4124 0         0 while ( !$self->_eof ) {
4125 0         0 my $content;
4126 0 0       0 if ( !defined( $content = <$fh> ) ) {
4127 0         0 last;
4128             }
4129 0 0       0 if ( $self->_inctounix ) {
4130 0         0 $content =~ s/\R/\n/g;
4131             }
4132 0 0       0 if ( !Undef->check($contentp) ) {
4133 0         0 ${$contentp} .= $content;
  0         0  
4134             }
4135 0 0       0 if ($parse) {
4136 0         0 $self->impl_parseIncremental($content);
4137 0 0       0 if ( is_interactive($fh) ) {
4138 0         0 $self->_dumpCurrent();
4139             }
4140             }
4141 0         0 $self->_set__eof(false);
4142             }
4143 0         0 $self->_set__eof(true);
4144 0 0       0 if ( $self->_canDebug('i') ) {
4145 0         0 $self->logger_debug('input exhausted');
4146             }
4147 0 0       0 if ( !close($fh) ) {
4148 0 0       0 if ( !$silent ) {
4149 0         0 $self->logger_warn(
4150             'Failed to close STDIN duplicate: %s', $! );
4151             }
4152             }
4153             }
4154             }
4155              
4156 29         640 return $self;
4157             }
4158              
4159 1 50   1   4392 method impl_parseIncremental (Str $input --> ConsumerOf[M4Impl]) {
  1 50   164   2  
  1 50       177  
  1 50       7  
  1 50       2  
  1         241  
  1         3231  
  164         2978  
  164         662  
  164         705  
  164         692  
  164         512  
  164         698  
  164         317  
4160             try {
4161             #
4162             # This can throw an exception
4163             #
4164 164     164   14529 $self->_set__unparsed(
4165             $self->parser_parse( $self->_unparsed . $input ) );
4166             }
4167             catch {
4168             #
4169             # Every ImplException must be preceeded by
4170             # a call to $self->logger_error.
4171             #
4172 3 50   3   7934 if ( !$self->impl_isImplException($_) ) {
4173             #
4174             # "$_" explicitely: if this is an object,
4175             # this will call the stringify overload
4176             #
4177 0         0 $self->logger_error( '%s', "$_" );
4178             }
4179             #
4180             # The whole thing is unparsed!
4181             #
4182 3         158 $self->_set__unparsed($input);
4183 3         197 return;
4184 164         2143 };
4185 164         20498 return $self;
4186             }
4187              
4188 1 50   1   2296 method impl_isImplException (Any $obj --> Bool) {
  1 50   3   2  
  1 50       148  
  1 50       7  
  1         3  
  1         210  
  1         2856  
  3         48  
  3         19  
  3         16  
  3         15  
  3         10  
  3         8  
  3         11  
4189 3         17 my $blessed = blessed($obj);
4190 3 50       12 if ( !$blessed ) {
4191 0         0 return false;
4192             }
4193 3   50     23 my $DOES = $obj->can('DOES') || 'isa';
4194 3 50       11 if ( !grep { $obj->$DOES($_) } (ImplException) ) {
  3         32  
4195 0         0 return false;
4196             }
4197 3         131 return true;
4198             }
4199              
4200 1 50   1   2745 method impl_appendValue (Str $result --> ConsumerOf[M4Impl]) {
  1 50   2904   2  
  1 50       182  
  1 50       8  
  1 50       2  
  1         87  
  1         2013  
  2904         186986  
  2904         8041  
  2904         7525  
  2904         7719  
  2904         4739  
  2904         8651  
  2904         4345  
4201 2904         47350 $self->_lastDiversion->print($result);
4202 2904         98713 return $self;
4203             }
4204              
4205 1 50   1   2130 method impl_parse (Str $input --> Str) {
  1 50   140   3  
  1 50       142  
  1 50       6  
  1 50       3  
  1         138  
  1         2842  
  140         1743  
  140         636  
  140         550  
  140         537  
  140         251  
  140         598  
  140         289  
4206 140 50       813 if ( $self->_eoi ) {
4207 0         0 $self->logger_error('No more input is accepted');
4208 0         0 return '';
4209             }
4210 140         926 $self->_set__eof(true);
4211 140         9432 return $self->impl_parseIncremental($input)->impl_value;
4212             }
4213              
4214 1 50   1   1884 method impl_setEoi (--> ConsumerOf[M4Impl]) {
  1 50   142   3  
  1         117  
  1         1665  
  142         1785  
  142         525  
  142         345  
4215 142         569 $self->_set__eoi(true);
4216 142         2856 $self->impl_freezeState;
4217 142         562 return $self;
4218             }
4219              
4220 1 50   1   1899 method impl_valueRef (--> Ref['SCALAR']) {
  1 50   140   2  
  1         146  
  1         2842  
  140         1684  
  140         569  
  140         266  
4221             #
4222             # If not already done, say input is over
4223             #
4224 140         2744 $self->impl_setEoi;
4225             #
4226             # Something left over ?
4227             #
4228 140 100       655 if ( $self->_unparsed ) {
4229 3         63 $self->impl_parseIncremental('');
4230             }
4231             #
4232             # Return a reference to the value
4233             #
4234 140         2518 return $self->_diversions_get(0)->sref;
4235             }
4236              
4237 1 50   1   1465 method impl_value (--> Str) {
  1 50   140   2  
  1         112  
  1         2698  
  140         11525  
  140         494  
  140         282  
4238 140         302 return ${ $self->impl_valueRef };
  140         2577  
4239             }
4240              
4241 1 0   1   1412 method impl_file (--> Str) {
  1 0   0   5  
  1         148  
  1         1659  
  0         0  
  0         0  
  0         0  
4242 0         0 return $self->__file__;
4243             }
4244              
4245 1 0   1   1403 method impl_program (--> Str) {
  1 0   0   3  
  1         96  
  1         2197  
  0         0  
  0         0  
  0         0  
4246 0         0 return $self->__program__;
4247             }
4248              
4249 1 0   1   1507 method impl_debugfile (--> Str) {
  1 0   0   3  
  1         121  
  1         1843  
  0         0  
  0         0  
  0         0  
4250 0         0 return $self->debugfile;
4251             }
4252              
4253 1 0   1   2420 method impl_canLog (Str $what --> Bool) {
  1 0   0   3  
  1 0       156  
  1 0       6  
  1 0       6  
  1         81  
  1         1867  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
4254 0         0 return $self->_canDebug($what);
4255             }
4256              
4257 1 0   1   1352 method impl_line (--> PositiveOrZeroInt) {
  1 0   0   3  
  1         142  
  1         2158  
  0         0  
  0         0  
  0         0  
4258 0         0 return $self->__line__;
4259             }
4260              
4261 1 0   1   1387 method impl_rc (--> Int) {
  1 0   0   2  
  1         96  
  1         2214  
  0         0  
  0         0  
  0         0  
4262 0         0 return $self->_rc;
4263             }
4264              
4265 1 0 0 1   4193 method _printable (Str|M4Macro $input, Bool $noQuote? --> Str) {
  1 0   0   3  
  1 0       191  
  1 0       7  
  1 0       3  
  1 0       218  
  1 0       7  
  1 0       2  
  1 0       144  
  1         1835  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
4266 0   0     0 $noQuote //= false;
4267             #
4268             # If M4Macro let's get the object representation stringified
4269             #
4270 0 0       0 my $printable = Str->check($input) ? $input : "$input";
4271              
4272 0 0       0 return Str->check($input)
    0          
4273             ? ( $noQuote ? $printable : $self->impl_quote($printable) )
4274             : $printable;
4275             }
4276              
4277 1 50 33 1   3771 method impl_macroExecute (ConsumerOf[M4Macro] $macro, @args --> Str|M4Macro) {
  1 50   11   3  
  1 50       188  
  1 50       7  
  1 50       2  
  1 50       272  
  1 100       1710  
  11         1718  
  11         43  
  11         42  
  11         44  
  11         23  
  11         25  
  11         60  
  11         57  
  11         44  
  11         260  
  11         26  
4278             #
4279             # m4wrap is not traced
4280             # include is not traced
4281             # sinclude is not traced
4282             #
4283 11 100 66     211 if ( $macro->stub == \&builtin_m4wrap
      66        
4284             || $macro->stub == \&builtin_include
4285             || $macro->stub == \&builtin_sinclude )
4286             {
4287 2         49 return $macro->macro_execute( $self, @args );
4288             }
4289             else {
4290 9         563 my $canTrace = $self->_canTrace($macro);
4291 9         371 return $self->impl_macroExecuteNoHeader( $macro,
4292             $self->impl_macroExecuteHeader( $macro, $canTrace ),
4293             $canTrace, @args );
4294             }
4295             }
4296              
4297 1 50 33 1   3620 method impl_macroExecuteHeader (ConsumerOf[M4Macro] $macro, Bool $canTrace --> PositiveOrZeroInt) {
  1 50   2450   2  
  1 50       179  
  1 50       6  
  1 50       3  
  1 50       173  
  1 50       6  
  1 50       2  
  1 50       166  
  1         6498  
  2450         25161  
  2450         6117  
  2450         6546  
  2450         6085  
  2450         5102  
  2450         4078  
  2450         10494  
  2450         10782  
  2450         8829  
  2450         54042  
  2450         6817  
  2450         3935  
  2450         7331  
  2450         3671  
4298 2450         5186 local $MarpaX::Languages::M4::MACRO = $macro;
4299 2450         50957 local $MarpaX::Languages::M4::MACROCALLID
4300             = $self->_set__macroCallId( $self->_macroCallId + 1 );
4301             #
4302             # Log the macro
4303             # We avoid these unnecessary calls by calling ourself _canTrace
4304             #
4305 2450 50       110038 if ($canTrace) {
4306 0         0 my $printableMacroName = $self->_printable( $macro->name, true );
4307              
4308 0         0 $self->logger_trace( '%s ...', $printableMacroName );
4309             }
4310              
4311 2450         38106 return $MarpaX::Languages::M4::MACROCALLID;
4312             }
4313              
4314 1 50 33 1   5621 method impl_macroExecuteNoHeader (ConsumerOf[M4Macro] $macro, PositiveOrZeroInt $macroCallId, Bool $canTrace, @args --> Str|M4Macro) {
  1 50   2449   3  
  1 50       194  
  1 50       7  
  1 50       3  
  1 50       171  
  1 50       6  
  1 50       2  
  1 50       105  
  1 50       5  
  1 50       2  
  1 50       452  
  1 100       2082  
  2449         26260  
  2449         7462  
  2449         8394  
  2449         6442  
  2449         3879  
  2449         3707  
  2449         10144  
  2449         10047  
  2449         7644  
  2449         53467  
  2449         7022  
  2449         3963  
  2449         7438  
  2449         7162  
  2449         6511  
  2449         3791  
  2449         7828  
  2449         10545  
  2449         3778  
4315             #
4316             # Execute the macro
4317             #
4318 2449         5012 local $MarpaX::Languages::M4::MACRO = $macro;
4319 2449         5690 local $MarpaX::Languages::M4::MACROCALLID = $macroCallId;
4320 2449         4621 my $printableMacroName;
4321              
4322 2449 0 0     5470 if ( $canTrace && ( $self->_canDebug('a') || $self->_canDebug('c') ) )
      33        
4323             {
4324 0         0 $printableMacroName = $self->_printable( $macro->name, true );
4325              
4326 0 0       0 if (@args) {
4327             my $printableArguments
4328 0         0 = join( ', ', map { $self->_printable($_) } @args );
  0         0  
4329 0         0 $self->logger_trace( '%s(%s) -> ???',
4330             $printableMacroName, $printableArguments );
4331             }
4332             else {
4333 0         0 $self->logger_trace( '%s -> ???', $printableMacroName );
4334             }
4335             }
4336              
4337 2449         47650 my $rc = $macro->macro_execute( $self, @args );
4338              
4339 2447 0 0     31853 if ( $canTrace && ( $self->_canDebug('e') || $self->_canDebug('c') ) )
      33        
4340             {
4341 0 0       0 if ( length($rc) > 0 ) {
4342 0 0       0 if (@args) {
4343 0         0 $self->logger_trace( '%s(...) -> %s',
4344             $printableMacroName, $self->_printable($rc) );
4345             }
4346             else {
4347 0         0 $self->logger_trace( '%s -> %s', $printableMacroName,
4348             $self->_printable($rc) );
4349             }
4350             }
4351             else {
4352 0 0       0 if (@args) {
4353 0         0 $self->logger_trace( '%s(...)', $printableMacroName );
4354             }
4355             else {
4356 0         0 $self->logger_trace( '%s', $printableMacroName );
4357             }
4358             }
4359             }
4360              
4361 2447         42192 return $rc;
4362             }
4363              
4364 1 0   1   1502 method impl_macroCallId (--> PositiveOrZeroInt) {
  1 0   0   2  
  1         98  
  1         6428  
  0         0  
  0         0  
  0         0  
4365 0         0 return $self->_macroCallId;
4366             }
4367              
4368 1 0   1   1414 method impl_unparsed (--> Str) {
  1 0   0   2  
  1         112  
  1         2123  
  0         0  
  0         0  
  0         0  
4369 0         0 return $self->_unparsed;
4370             }
4371              
4372 1 50   1   1378 method impl_eoi (--> Bool) {
  1 50   1   3  
  1         98  
  1         1746  
  1         13  
  1         3  
  1         2  
4373 1         18 return $self->_eoi;
4374             }
4375              
4376 1 50   1   2598 method impl_raiseException (Str $message --> Undef) {
  1 50   7   2  
  1 50       191  
  1 50       7  
  1 50       2  
  1         117  
  1         2052  
  7         86  
  7         29  
  7         32  
  7         30  
  7         16  
  7         30  
  7         17  
4377 7         139 $self->logger_error($message);
4378 7         46 ImplException->throw($message);
4379             }
4380              
4381 1         2047 has _nbInputProcessed => (
4382             is => 'rwp',
4383             isa => PositiveOrZeroInt,
4384             handles_via => 'Number',
4385             default => 0
4386             );
4387              
4388 1 0   1   1469 method impl_nbInputProcessed (--> PositiveOrZeroInt) {
  1 0   0   2  
  1         99  
  1         1469  
  0            
  0            
  0            
4389 0           return $self->_nbInputProcessed;
4390             }
4391              
4392 1 0   1   1968 method impl_readFromStdin (--> ConsumerOf[M4Impl]) {
  1 0   0   2  
  1         110  
  1         2057  
  0            
  0            
  0            
4393 0           $self->interactive(true);
4394 0           return $self;
4395             }
4396              
4397 1 0   1   2020 method impl_debugFile (--> Undef|Str) {
  1 0   0   3  
  1         156  
  1         2959  
  0            
  0            
  0            
4398 0           return $self->_debugfile;
4399             }
4400              
4401 1 0   1   1510 method impl_nestingLimit (--> PositiveOrZeroInt) {
  1 0   0   3  
  1         238  
  1         3354  
  0            
  0            
  0            
4402 0           return $self->_nesting_limit;
4403             }
4404              
4405 1         1966 with 'MarpaX::Languages::M4::Role::Impl';
4406 1         2695 with 'MooX::Role::Logger';
4407             }
4408              
4409             1;
4410              
4411             __END__
4412              
4413             =pod
4414              
4415             =encoding UTF-8
4416              
4417             =head1 NAME
4418              
4419             MarpaX::Languages::M4::Impl::Default - M4 pre-processor - default implementation
4420              
4421             =head1 VERSION
4422              
4423             version 0.019
4424              
4425             =head1 AUTHOR
4426              
4427             Jean-Damien Durand <jeandamiendurand@free.fr>
4428              
4429             =head1 COPYRIGHT AND LICENSE
4430              
4431             This software is copyright (c) 2015 by Jean-Damien Durand.
4432              
4433             This is free software; you can redistribute it and/or modify it under
4434             the same terms as the Perl 5 programming language system itself.
4435              
4436             =cut