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   7 use Moops;
  1         2  
  1         5  
2 1     1   1753 use MarpaX::Languages::M4::Impl::Parser;
  1         3  
  1         16  
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   2219 class MarpaX::Languages::M4::Impl::Default {
  1     1   27  
  1         7  
  1         2  
  1         62  
  1         5  
  1         2  
  1         9  
  1         310  
  1         2  
  1         7  
  1         60  
  1         2  
  1         44  
  1         4  
  1         3  
  1         78  
  1         71  
  1         6  
  1         2  
  1         8  
  1         4563  
  1         3  
  1         7  
  1         383  
  1         2  
  1         8  
  1         135  
  1         2  
  1         7  
  1         76  
  1         2  
  1         11  
  1         201  
  1         2  
  1         7  
  1         820  
  1         2  
  1         8  
  1         1858  
  1         3  
  1         5  
  1         2  
  1         20  
  1         4  
  1         2  
  1         39  
  1         5  
  1         2  
  1         122  
  1         10931  
40 1         14 extends 'MarpaX::Languages::M4::Impl::Parser';
41              
42 1         186 our $VERSION = '0.020'; # VERSION
43              
44 1         2 our $AUTHORITY = 'cpan:JDDPAUSE'; # AUTHORITY
45              
46 1     1   354 use Bit::Vector;
  1         751  
  1         50  
47 1     1   280 use Encode::Locale;
  1         2558  
  1         44  
48 1     1   6 use Encode;
  1         2  
  1         75  
49 1     1   263 use Env::Path qw/M4PATH/;
  1         2233  
  1         5  
50 1     1   125 use Errno;
  1         3  
  1         41  
51 1     1   5 use File::Find;
  1         2  
  1         56  
52 1     1   5 use File::Spec;
  1         2  
  1         14  
53 1     1   23 use File::Temp;
  1         3  
  1         68  
54 1     1   268 use IO::CaptureOutput qw/capture_exec/;
  1         1723  
  1         53  
55 1     1   6 use IO::Handle;
  1         2  
  1         33  
56 1     1   256 use IO::File;
  1         823  
  1         159  
57 1     1   242 use IO::Interactive qw/is_interactive/;
  1         763  
  1         6  
58 1     1   377 use IO::Scalar;
  1         3323  
  1         46  
59 1     1   289 use MarpaX::Languages::M4::Impl::Default::BaseConversion;
  1         3  
  1         12  
60 1     1   482 use MarpaX::Languages::M4::Impl::Default::Eval;
  1         4  
  1         13  
61 1     1   404 use MarpaX::Languages::M4::Impl::Macros;
  1         3  
  1         9  
62 1     1   427 use MarpaX::Languages::M4::Impl::Macro;
  1         4  
  1         9  
63 1     1   447 use MarpaX::Languages::M4::Impl::Regexp;
  1         4  
  1         10  
64 1     1   471 use MarpaX::Languages::M4::Role::Impl;
  1         4  
  1         9  
65 1     1   70 use MarpaX::Languages::M4::Type::Macro -all;
  1         2  
  1         10  
66 1     1   1228 use MarpaX::Languages::M4::Type::Impl -all;
  1         4  
  1         14  
67 1     1   824 use MarpaX::Languages::M4::Type::Regexp -all;
  1         2  
  1         8  
68 1     1   1616 use MarpaX::Languages::M4::Type::Token -all;
  1         3  
  1         13  
69 1     1   772 use Marpa::R2;
  1         2  
  1         11  
70 1     1   25 use MooX::HandlesVia;
  1         2  
  1         8  
71 1     1   124 use Scalar::Util qw/blessed/;
  1         2  
  1         63  
72 1     1   333 use Throwable::Factory ImplException => undef;
  1         36126  
  1         7  
73 1     1   2995 use MooX::Options 4.103 protect_argv => 0, flavour => [qw/require_order/];
  1         1726  
  1         6  
74 1     1   54835 use MooX::Role::Logger;
  1         2293  
  1         14  
75 1     1   46 use POSIX qw/EXIT_SUCCESS EXIT_FAILURE/;
  1         2  
  1         7  
76 1     1   791 use Perl::OSType ':all';
  1         383  
  1         131  
77 1     1   7 use Types::Common::Numeric -all;
  1         2  
  1         12  
78              
79             # -----------------------------------------------------------------
80             # The list of GNU-like extensions is known in advanced and is fixed
81             # -----------------------------------------------------------------
82 1         15 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         12 our @nums = ( 0 .. 9, 'a' .. 'z', 'A' .. 'Z' );
116 1         3 our %nums = map { $nums[$_] => $_ } 0 .. $#nums;
  62         126  
117 1         19 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   7650 around new_with_options {
  1 50   140   2  
  1         454  
  1         150456  
  140         397331  
  140         656  
  140         554  
  140         320  
199             #
200             # $self is in reality a $class
201             #
202 140         359 my $class = $self;
203 140         897 $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         7437 local $MarpaX::Languages::M4::SELF = $self;
210 140         821 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         1090 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         882 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         2099 has _stateReloaded => ( is => 'rwp', isa => Bool, default => false );
268              
269 1 0   1   3002 method _trigger_reload_state (Str $reloadState, @rest --> Undef) {
  1 0   0   3  
  1 0       143  
  1 0       7  
  1 0       2  
  1 0       200  
  1         1410  
  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         2393 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         1378 has _stateFreezed => ( is => 'rwp', isa => Bool, default => false );
288              
289             # =========================
290             # --cmdtounix
291             # =========================
292 1         1643 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         1315 has _cmdtounix => ( is => 'rwp', isa => Bool, lazy => 1, builder => 1 );
301              
302 1 50   1   3008 method _trigger_cmdtounix (Bool $cmdtounix, @rest --> Undef) {
  1 50   140   2  
  1 50       138  
  1 50       9  
  1 50       2  
  1 50       113  
  1         2133  
  140         13383  
  140         687  
  140         749  
  140         711  
  140         469  
  140         840  
  140         692  
  140         391  
303 140         2934 $self->_set__cmdtounix($cmdtounix);
304 140         4664 return;
305             }
306              
307 1 0   1   1028 method _build__cmdtounix {false}
  1     0   3  
  1         113  
  1         2315  
  0         0  
  0         0  
  0         0  
308              
309             # =======================================
310             # --changeword-is-character-per-character
311             # =======================================
312 1         224 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         1431 has _changeword_is_character_per_character =>
321             ( is => 'rwp', isa => Bool, lazy => 1, builder => 1 );
322              
323 1 50   1   3273 method _trigger_changeword_is_character_per_character (Bool $changeword_is_character_per_character, @rest --> Undef) {
  1 50   2   2  
  1 50       135  
  1 50       6  
  1 50       2  
  1 50       141  
  1         2131  
  2         212  
  2         12  
  2         9  
  2         12  
  2         4  
  2         13  
  2         10  
  2         7  
324 2         45 $self->_set__changeword_is_character_per_character(
325             $changeword_is_character_per_character);
326 2         96 return;
327             }
328              
329 1 50   1   1262 method _build__changeword_is_character_per_character {true}
  1     136   2  
  1         120  
  1         2272  
  136         2063  
  136         256  
  136         538  
330              
331             # =========================
332             # --inctounix
333             # =========================
334 1         195 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         1358 has _inctounix => ( is => 'rwp', isa => Bool, lazy => 1, builder => 1 );
343              
344 1 50   1   2925 method _trigger_inctounix (Bool $inctounix, @rest --> Undef) {
  1 50   140   3  
  1 50       141  
  1 50       7  
  1 50       2  
  1 50       122  
  1         2053  
  140         13717  
  140         657  
  140         674  
  140         580  
  140         337  
  140         752  
  140         659  
  140         401  
345 140         2840 $self->_set__inctounix($inctounix);
346 140         4521 return;
347             }
348              
349 1 0   1   1045 method _build__inctounix {false}
  1     0   3  
  1         224  
  1         2070  
  0         0  
  0         0  
  0         0  
350              
351             # =========================
352             # --tokens-priority
353             # =========================
354 1         160 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         6710 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         6 @{$DEFAULT_TOKENS_PRIORITY}
  1         98  
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         2919 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   3769 method _trigger_tokens_priority (ArrayRef[Str] $tokens_priority, @rest --> Undef) {
  1 0   0   3  
  1 0       151  
  1 0       6  
  1 0       2  
  1 0       349  
  1         5140  
  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   1123 method _build__tokens_priority {$DEFAULT_TOKENS_PRIORITY}
  1     139   2  
  1         133  
  1         2272  
  139         4462  
  139         371  
  139         2064  
406              
407             # =========================
408             # --integer-type
409             # =========================
410 1         172 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         1449 has _integer_type => (
419             is => 'rwp',
420             lazy => 1,
421             builder => 1,
422             isa => Enum [qw/native bitvector/]
423             );
424              
425 1 0   1   3184 method _trigger_integer_type (Str $integer_type, @rest --> Undef) {
  1 0   0   3  
  1 0       153  
  1 0       10  
  1 0       2  
  1 0       136  
  1         2707  
  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   1192 method _build__integer_type {'bitvector'}
  1     11   2  
  1         133  
  1         2227  
  11         158  
  11         27  
  11         155  
431              
432             # =========================
433             # --regexp-type
434             # =========================
435 1         161 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         1436 has _regexp_type => (
444             is => 'rwp',
445             lazy => 1,
446             builder => 1,
447             isa => M4RegexpType
448             );
449              
450 1 50   1   3099 method _trigger_regexp_type (Str $regexp_type, @rest --> Undef) {
  1 50   7   2  
  1 50       136  
  1 50       6  
  1 50       2  
  1 50       164  
  1         2081  
  7         759  
  7         45  
  7         39  
  7         36  
  7         17  
  7         39  
  7         36  
  7         22  
451 7         149 $self->_set__regexp_type($regexp_type);
452 7         350 return;
453             }
454              
455 1 50   1   1097 method _build__regexp_type {'GNU'}
  1     13   2  
  1         156  
  1         2168  
  13         247  
  13         38  
  13         248  
456              
457             # =========================
458             # --integer-bits
459             # =========================
460 1         196 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         1252 has _integer_bits => (
471             is => 'rwp',
472             lazy => 1,
473             builder => 1,
474             isa => PositiveInt,
475             );
476              
477 1 0   1   3150 method _trigger_integer_bits (Str $integer_bits, @rest --> Undef) {
  1 0   0   3  
  1 0       145  
  1 0       7  
  1 0       2  
  1 0       115  
  1         1762  
  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   1170 method _build__integer_bits {$INTEGER_BITS_DEFAULT_VALUE}
  1     18   2  
  1         153  
  1         2179  
  18         278  
  18         42  
  18         265  
483              
484             # =========================
485             # --m4wrap-order
486             # =========================
487 1         217 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         1496 has _m4wrap_order => (
497             is => 'rwp',
498             lazy => 1,
499             builder => 1,
500             isa => Enum [qw/LIFO FIFO/]
501             );
502              
503 1 0   1   3066 method _trigger_m4wrap_order (Str $m4wrap_order, @rest --> Undef) {
  1 0   0   3  
  1 0       173  
  1 0       7  
  1 0       3  
  1 0       113  
  1         2753  
  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   1107 method _build__m4wrap_order {'LIFO'}
  1     8   3  
  1         124  
  1         2239  
  8         123  
  8         22  
  8         117  
509              
510             # =========================
511             # --divert-type
512             # =========================
513 1         163 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         1480 has _divert_type => (
523             is => 'rwp',
524             lazy => 1,
525             builder => 1,
526             isa => Enum [qw/memory file/]
527             );
528              
529 1 0   1   2919 method _trigger_divert_type (Str $divert_type, @rest --> Undef) {
  1 0   0   4  
  1 0       138  
  1 0       6  
  1 0       2  
  1 0       105  
  1         2597  
  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   1076 method _build__divert_type {'memory'}
  1     24   2  
  1         248  
  1         2067  
  24         408  
  24         52  
  24         419  
535              
536             # =========================
537             # --builtin-need-param
538             # =========================
539 1         203 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         48696 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         4 . join( ',', @{$NEED_PARAM_DEFAULT_VALUE} ) . '.'
  1         95  
584             );
585              
586 1         2540 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   3622 method _trigger_builtin_need_param (ArrayRef[Str] $builtin_need_param, @rest --> Undef) {
  1 0   0   2  
  1 0       135  
  1 0       6  
  1 0       2  
  1 0       308  
  1         6108  
  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   1106 method _build__builtin_need_param {
  1     138   2  
  1         459  
  1         2264  
  138         4517  
  138         296  
629 138         356 my %ref = map { $_ => true } @{$NEED_PARAM_DEFAULT_VALUE};
  4002         13391  
  138         454  
630 138         5666 \%ref;
631             }
632              
633             # =========================
634             # --param-can-be-macro
635             # =========================
636 1         208 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         17 $PARAMCANBEMACRO_DEFAULT_VALUE_HASH->{$macroName}->{$_}
656             } keys
657 4         7 %{ $PARAMCANBEMACRO_DEFAULT_VALUE_HASH->{$macroName} }
  4         9  
658             )
659 1         16 } keys %{$PARAMCANBEMACRO_DEFAULT_VALUE_HASH}
  1         5  
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         6638 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         6 . join( ',', @{$PARAMCANBEMACRO_DEFAULT_VALUE} ) . '.'
  1         96  
674             );
675              
676 1         2536 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   3391 method _trigger_param_can_be_macro (ArrayRef[Str] $param_can_be_macro, @rest --> Undef) {
  1 0   0   2  
  1 0       145  
  1 0       7  
  1 0       2  
  1 0       641  
  1         9107  
  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   5879 return $PARAMCANBEMACRO_DEFAULT_VALUE_HASH;
748             }
749              
750             # =========================
751             # --interactive
752             # =========================
753 1         2370 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   1401 method _dumpCurrent (--> Undef) {
  1 0   0   2  
  1         162  
  1         1640  
  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   2732 method _trigger_interactive (Bool $interactive, @rest --> Undef) {
  1 0   0   1  
  1 0       126  
  1 0       6  
  1 0       1  
  1 0       193  
  1         1979  
  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         1968 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   2632 method _trigger_version (Bool $version, @rest --> Undef) {
  1 0   0   3  
  1 0       132  
  1 0       7  
  1 0       2  
  1 0       116  
  1         1454  
  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   13 no strict 'vars';
  1         2  
  1         173  
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         2054 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         1328 has _prefix_builtins => (
823             is => 'rwp',
824             lazy => 1,
825             builder => 1,
826             isa => Str,
827             );
828              
829 1 50   1   2808 method _trigger_prefix_builtins (Bool $prefix_builtins, @rest --> Undef) {
  1 50   1   2  
  1 50       132  
  1 50       6  
  1 50       2  
  1 50       106  
  1         1980  
  1         136  
  1         9  
  1         8  
  1         7  
  1         4  
  1         5  
  1         6  
  1         2  
830 1         31 $self->_set__prefix_builtins('m4_');
831 1         44 return;
832             }
833 1 50   1   1018 method _build__prefix_builtins {''}
  1     137   2  
  1         117  
  1         1942  
  137         2319  
  137         292  
  137         2186  
834              
835             # =========================
836             # --fatal-warnings
837             # =========================
838 1         167 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         1165 has _fatal_warnings => (
849             is => 'rwp',
850             lazy => 1,
851             builder => 1,
852             isa => PositiveOrZeroInt
853             );
854              
855 1 50   1   2798 method _trigger_fatal_warnings (PositiveInt $fatal_warnings, @rest --> Undef) {
  1 50   1   2  
  1 50       126  
  1 50       7  
  1 50       2  
  1 50       107  
  1         1675  
  1         182  
  1         8  
  1         6  
  1         8  
  1         3  
  1         8  
  1         6  
  1         5  
856 1         30 $self->_set__fatal_warnings($fatal_warnings);
857 1         61 return;
858             }
859              
860 1 50   1   1013 method _build__fatal_warnings {0}
  1     13   2  
  1         101  
  1         1961  
  13         280  
  13         41  
  13         249  
861              
862             # =========================
863             # --silent
864             # =========================
865 1         167 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         508 has _silent => (
874             is => 'rwp',
875             lazy => 1,
876             builder => 1,
877             );
878              
879 1 0   1   2655 method _trigger_silent (Bool $silent, @rest --> Undef) {
  1 0   0   3  
  1 0       146  
  1 0       7  
  1 0       2  
  1 0       108  
  1         905  
  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   951 method _build__silent {false}
  1     0   2  
  1         200  
  1         1915  
  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         6322 default => sub { return [] },
900 1         164 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         2693 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   3158 method _trigger_trace (ArrayRef[Str] $arrayRef, @rest --> Undef) {
  1 0   0   3  
  1 0       137  
  1 0       6  
  1 0       2  
  1 0       145  
  1         5247  
  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   1011 method _build__trace { {} }
  1     138   2  
  1         142  
  1         2339  
  138         25006  
  138         273  
  138         2099  
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         7344 default => sub { return [] },
937 1         219 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   3153 method _trigger_define (ArrayRef[Str] $arrayRef, @rest --> Undef) {
  1 0   0   2  
  1 0       131  
  1 0       6  
  1 0       2  
  1 0       803  
  1         2657  
  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         5899 default => sub { return [] },
995 1         2067 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   3064 method _trigger_undefine (ArrayRef[Str] $arrayRef, @rest --> Undef) {
  1 0   0   2  
  1 0       132  
  1 0       6  
  1 0       2  
  1 0       387  
  1         2778  
  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         6124 default => sub { return [] },
1041 1         2057 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         2647 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   3282 method _trigger_prepend_include (ArrayRef[Str] $prepend_include, @rest --> Undef) {
  1 0   0   2  
  1 0       131  
  1 0       9  
  1 0       2  
  1 0       115  
  1         3457  
  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   1082 method _build__prepend_include { [] }
  1     20   3  
  1         187  
  1         2051  
  20         716  
  20         54  
  20         308  
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         9552 default => sub { return [] },
1072 1         169 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         2458 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   3193 method _trigger_include (ArrayRef[Str] $include, @rest --> Undef) {
  1 50   140   3  
  1 50       174  
  1 50       6  
  1 50       2  
  1 50       107  
  1         3499  
  140         14461  
  140         704  
  140         870  
  140         640  
  140         371  
  140         817  
  140         707  
  140         394  
1089 140         3081 $self->_set__include($include);
1090 140         4607 return;
1091             }
1092 1 0   1   959 method _build__include { [] }
  1     0   2  
  1         110  
  1         2081  
  0         0  
  0         0  
  0         0  
1093              
1094             # =========================
1095             # --synclines
1096             # =========================
1097 1         164 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         1312 has _synclines => (
1108             is => 'rwp',
1109             lazy => 1,
1110             builder => 1,
1111             isa => Bool,
1112             );
1113              
1114 1 0   1   2702 method _trigger_synclines (Bool $synclines, @rest --> Undef) {
  1 0   0   3  
  1 0       159  
  1 0       6  
  1 0       6  
  1 0       111  
  1         2054  
  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   977 method _build__synclines { return false }
  1     0   2  
  1         119  
  1         2038  
  0         0  
  0         0  
  0         0  
1119              
1120             # =========================
1121             # --gnu
1122             # =========================
1123 1         170 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         1430 has _no_gnu_extensions => (
1134             is => 'rwp',
1135             lazy => 1,
1136             builder => 1,
1137             isa => Bool
1138             );
1139              
1140 1 0   1   2654 method _trigger_gnu (Bool $gnu, @rest --> Undef) {
  1 0   0   2  
  1 0       238  
  1 0       9  
  1 0       3  
  1 0       135  
  1         2035  
  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   1045 method _build__no_gnu_extensions {false}
  1     137   2  
  1         118  
  1         2157  
  137         2089  
  137         275  
  137         409  
1145              
1146             # =========================
1147             # --traditional
1148             # =========================
1149 1         165 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   2841 method _trigger_traditional (Bool $traditional, @rest --> Undef) {
  1 50   1   6  
  1 50       133  
  1 50       6  
  1 50       2  
  1 50       234  
  1         1341  
  1         105  
  1         5  
  1         6  
  1         4  
  1         3  
  1         5  
  1         5  
  1         3  
1160 1         23 $self->_set__no_gnu_extensions($traditional);
1161 1         43 return;
1162             }
1163              
1164             # =========================
1165             # --debugmode
1166             # =========================
1167 1         1970 our @DEBUG_FLAGS = qw/a c e f i l p q t x/;
1168 1         3 our @DEFAULT_DEBUG_FLAGS = qw/a e q/;
1169 1         6 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         1474 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   2627 method _trigger_debug (Str $flags, @rest --> Undef) {
  1 0   0   2  
  1 0       137  
  1 0       6  
  1 0       3  
  1 0       528  
  1         5452  
  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   956 method _build__debug {
  1     138   2  
  1         209  
  1         2249  
  138         4586  
  138         304  
1236 138         366 my %ref = ();
1237 138         608 map { $ref{$_} = false } @DEBUG_FLAGS;
  1380         7005  
1238 138         1072 map { $ref{$_} = true } @DEFAULT_DEBUG_FLAGS;
  414         1526  
1239 138         2742 return \%ref;
1240             }
1241              
1242             # =========================
1243             # --nesting_limit
1244             # =========================
1245 1         167 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         1260 has _nesting_limit => (
1257             is => 'rwp',
1258             lazy => 1,
1259             builder => 1,
1260             isa => PositiveOrZeroInt
1261             );
1262              
1263 1 0   1   2759 method _trigger_nesting_limit (PositiveOrZeroInt $nesting_limit, @rest --> Undef) {
  1 0   0   2  
  1 0       161  
  1 0       7  
  1 0       2  
  1 0       103  
  1         1755  
  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   1000 method _build__nesting_limit {$DEFAULT_NESTING_LIMIT}
  1     0   2  
  1         162  
  1         1997  
  0         0  
  0         0  
  0         0  
1268              
1269             # =========================
1270             # --debugfile
1271             # =========================
1272 1         169 our $DEFAULT_DEBUGFILE = undef;
1273 1         5 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         1399 has _debugfile => (
1284             is => 'rwp',
1285             lazy => 1,
1286             builder => 1,
1287             isa => Undef | Str,
1288             );
1289              
1290 1 0   1   2721 method _trigger_debugfile (Str $debugfile, @rest --> Undef) {
  1 0   0   2  
  1 0       149  
  1 0       6  
  1 0       2  
  1 0       104  
  1         2612  
  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   988 method _build__debugfile {$DEFAULT_DEBUGFILE}
  1     2   2  
  1         157  
  1         2123  
  2         35  
  2         4  
  2         28  
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         1468 has _quote_start => (
1310             is => 'rwp',
1311             lazy => 1,
1312             builder => 1,
1313             trigger => 1,
1314             isa => Str,
1315             );
1316              
1317 1         2156 has _quoteStartLength => (
1318             is => 'rwp',
1319             lazy => 1,
1320             builder => 1,
1321             isa => PositiveOrZeroInt
1322             );
1323              
1324 1 0   1   3084 method _trigger_quote_start (Str $quote_start, @rest --> Undef) {
  1 0   0   2  
  1 0       146  
  1 0       6  
  1 0       2  
  1 0       139  
  1         1705  
  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   2849 method _trigger__quote_start (Str $quote_start, @rest --> Undef) {
  1 50   23   2  
  1 50       140  
  1 50       6  
  1 50       2  
  1 50       149  
  1         2569  
  23         1811  
  23         118  
  23         114  
  23         81  
  23         48  
  23         102  
  23         118  
  23         58  
1331 23         472 $self->_set__quoteStartLength( length($quote_start) );
1332             }
1333              
1334 1 50   1   1017 method _build__quote_start {$DEFAULT_QUOTE_START}
  1     139   2  
  1         76  
  1         2019  
  139         2570  
  139         266  
  139         2251  
1335 1 50   1   1061 method _build__quoteStartLength { length($DEFAULT_QUOTE_START) }
  1     139   2  
  1         189  
  1         173  
  139         2168  
  139         292  
  139         2260  
1336              
1337             # =========================
1338             # --quote-end
1339             # =========================
1340 1         162 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         1636 has _quote_end => (
1351             is => 'rwp',
1352             lazy => 1,
1353             builder => 1,
1354             trigger => 1,
1355             isa => Str,
1356             );
1357              
1358 1         2224 has _quoteEndLength => (
1359             is => 'rwp',
1360             lazy => 1,
1361             builder => 1,
1362             isa => PositiveOrZeroInt
1363             );
1364              
1365 1 0   1   2731 method _trigger_quote_end (Str $quote_end, @rest --> Undef) {
  1 0   0   3  
  1 0       143  
  1 0       6  
  1 0       2  
  1 0       148  
  1         1907  
  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   2710 method _trigger__quote_end (Str $quote_end, @rest --> Undef) {
  1 50   23   2  
  1 50       141  
  1 50       6  
  1 50       2  
  1 50       108  
  1         2285  
  23         1614  
  23         126  
  23         102  
  23         96  
  23         42  
  23         115  
  23         100  
  23         51  
1372 23         422 $self->_set__quoteEndLength( length($quote_end) );
1373             }
1374              
1375 1 50   1   989 method _build__quote_end {$DEFAULT_QUOTE_END}
  1     139   2  
  1         74  
  1         2018  
  139         2070  
  139         333  
  139         2190  
1376 1 50   1   1034 method _build__quoteEndLength { length($DEFAULT_QUOTE_END) }
  1     139   2  
  1         167  
  1         175  
  139         2269  
  139         390  
  139         2214  
1377              
1378             # =========================
1379             # --comment-start
1380             # =========================
1381 1         163 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         1639 has _comment_start => (
1392             is => 'rwp',
1393             lazy => 1,
1394             builder => 1,
1395             trigger => 1,
1396             isa => Str,
1397             );
1398              
1399 1         2314 has _commentStartLength => (
1400             is => 'rwp',
1401             lazy => 1,
1402             builder => 1,
1403             isa => PositiveOrZeroInt
1404             );
1405              
1406 1 0   1   2746 method _trigger_comment_start (Str $comment_start, @rest --> Undef) {
  1 0   0   2  
  1 0       152  
  1 0       6  
  1 0       2  
  1 0       123  
  1         1874  
  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   2757 method _trigger__comment_start (Str $comment_start, @rest --> Undef) {
  1 50   16   2  
  1 50       142  
  1 50       6  
  1 50       3  
  1 50       118  
  1         2238  
  16         1440  
  16         72  
  16         78  
  16         80  
  16         30  
  16         72  
  16         67  
  16         37  
1413 16         334 $self->_set__commentStartLength( length($comment_start) );
1414             }
1415              
1416 1 50   1   1026 method _build__comment_start {$DEFAULT_COMMENT_START}
  1     139   3  
  1         217  
  1         2021  
  139         2201  
  139         300  
  139         2333  
1417              
1418             sub _build__commentStartLength {
1419 139     139   3596 return length($DEFAULT_COMMENT_START);
1420             }
1421              
1422             # =========================
1423             # --comment-end
1424             # =========================
1425 1         218 our $DEFAULT_COMMENT_END = "\n";
1426 1         5 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         1536 has _comment_end => (
1436             is => 'rwp',
1437             lazy => 1,
1438             builder => 1,
1439             trigger => 1,
1440             isa => Str,
1441             );
1442              
1443 1         2500 has _commentEndLength => (
1444             is => 'rwp',
1445             lazy => 1,
1446             builder => 1,
1447             isa => PositiveOrZeroInt
1448             );
1449              
1450 1 0   1   2732 method _trigger_comment_end (Str $comment_end, @rest --> Undef) {
  1 0   0   2  
  1 0       144  
  1 0       6  
  1 0       3  
  1 0       133  
  1         2027  
  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   2692 method _trigger__comment_end (Str $comment_end, @rest --> Undef) {
  1 50   16   2  
  1 50       138  
  1 50       9  
  1 50       2  
  1 50       108  
  1         2616  
  16         1208  
  16         72  
  16         62  
  16         64  
  16         42  
  16         137  
  16         91  
  16         52  
1457 16         382 $self->_set__commentEndLength( length($comment_end) );
1458             }
1459              
1460 1 50   1   1017 method _build__comment_end {$DEFAULT_COMMENT_END}
  1     139   1  
  1         76  
  1         2292  
  139         2018  
  139         290  
  139         2075  
1461 1 50   1   1065 method _build__commentEndLength { length($DEFAULT_COMMENT_END) }
  1     139   2  
  1         207  
  1         217  
  139         1940  
  139         273  
  139         2137  
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         207 our $DEFAULT_WORD_REGEXP = '[_a-zA-Z][_a-zA-Z0-9]*';
1470 1         6 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         1809 has _word_regexp => (
1481             is => 'rwp',
1482             lazy => 1,
1483             builder => 1,
1484             isa => Str
1485             );
1486              
1487 1         2440 has _regexp_word => (
1488             is => 'rwp',
1489             lazy => 1,
1490             builder => 1,
1491             isa => InstanceOf [M4Regexp]
1492             );
1493              
1494 1         3296 has _regexp_isDefault => (
1495             is => 'rwp',
1496             default => true,
1497             isa => Bool
1498             );
1499              
1500 1 50   1   2738 method _trigger_word_regexp (Str $regexpString, @rest --> Undef) {
  1 50   11   2  
  1 50       141  
  1 50       7  
  1 50       1  
  1 50       241  
  1         1728  
  11         852  
  11         49  
  11         58  
  11         45  
  11         28  
  11         54  
  11         46  
  11         31  
1501 11 50       75 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       290 my $regexp_type
1512             = ( $regexpString eq $DEFAULT_WORD_REGEXP )
1513             ? 'perl'
1514             : $self->_regexp_type;
1515 11         386 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1516 11 50       497 if ( $r->regexp_compile( $self, $regexp_type, $regexpString ) ) {
1517 11         550 $self->_set__word_regexp($regexpString);
1518 11         498 $self->_set__regexp_word($r);
1519             }
1520             $self->_set__regexp_isDefault(
1521 11 50       822 ( $regexpString eq $DEFAULT_WORD_REGEXP ) ? true : false );
1522              
1523 11         464 return;
1524             }
1525              
1526             #
1527             # Why perltidier does not like it without @args ?
1528             #
1529 1 50   1   1454 method _build__word_regexp (@args) {
  1 50   139   3  
  1         109  
  1         2848  
  139         1899  
  139         691  
  139         305  
1530 139         2162 return $DEFAULT_WORD_REGEXP;
1531             }
1532              
1533 1 50   1   1728 method _build__regexp_word (@args) {
  1 50   139   3  
  1         268  
  1         252  
  139         2055  
  139         621  
  139         266  
1534 139         3387 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1535 139 50       8407 my $regexp_type
1536             = ( $self->_word_regexp eq $DEFAULT_WORD_REGEXP )
1537             ? 'perl'
1538             : $self->_regexp_type;
1539 139         5716 $r->regexp_compile( $self, $regexp_type, $self->_word_regexp );
1540 139         2794 return $r;
1541             }
1542              
1543             # ============================
1544             # --warn-macro-sequence-regexp
1545             # ============================
1546 1         241 our $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_GNU
1547             = '\$\({[^}]*}\|[0-9][0-9]+\)';
1548 1         3 our $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_PERL
1549             = '\$(\{[^\}]*\}|[0-9][0-9]+)';
1550 1         6 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         2012 has _warn_macro_sequence_regexp => (
1560             is => 'rwp',
1561             lazy => 1,
1562             builder => 1,
1563             isa => M4Regexp
1564             );
1565              
1566 1 50   1   1130 method _build__warn_macro_sequence_regexp {
  1     1   2  
  1         129  
  1         2845  
  1         24  
  1         2  
1567 1 50       25 my $regexpString
1568             = ( $self->_regexp_type eq 'GNU' )
1569             ? $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_GNU
1570             : $DEFAULT_WARN_MACRO_SEQUENCE_REGEXP_PERL;
1571 1         57 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
1572 1         36 $r->regexp_compile( $self, $self->_regexp_type, $regexpString );
1573 1         18 return $r;
1574             }
1575              
1576 1 0   1   2884 method _trigger_warn_macro_sequence_regexp (Str $regexpString, @rest --> Undef) {
  1 0   0   2  
  1 0       142  
  1 0       6  
  1 0       2  
  1 0       256  
  1         292  
  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         2559 our $DEFAULT_WARN_MACRO_SEQUENCE = false;
1592 1         12 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         1755 has _warn_macro_sequence => (
1602             is => 'rwp',
1603             lazy => 1,
1604             builder => 1,
1605             isa => Bool
1606             );
1607              
1608 1 50   1   2801 method _trigger_warn_macro_sequence (Bool $bool, @rest --> Undef) {
  1 50   1   3  
  1 50       160  
  1 50       6  
  1 50       2  
  1 50       114  
  1         2369  
  1         92  
  1         6  
  1         4  
  1         5  
  1         4  
  1         8  
  1         7  
  1         2  
1609 1         164 $self->_set__warn_macro_sequence($bool);
1610 1         45 return;
1611             }
1612              
1613 1 50   1   1064 method _build__warn_macro_sequence {
  1     94   3  
  1         110  
  1         3009  
  94         1348  
  94         193  
1614 94         1547 return $DEFAULT_WARN_MACRO_SEQUENCE;
1615             }
1616              
1617             # ---------------------------------------------------------------
1618             # PARSER REQUIRED METHODS
1619             # ---------------------------------------------------------------
1620              
1621 1 50   1   5792 method parser_isWord (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   15088   3  
  1 50       167  
  1 50       6  
  1 50       3  
  1 50       119  
  1 50       6  
  1 50       4  
  1 50       136  
  1 50       7  
  1 50       2  
  1 50       109  
  1 50       6  
  1 50       2  
  1 50       120  
  1 50       7  
  1 50       2  
  1         502  
  1         212  
  15088         130726  
  15088         35587  
  15088         51360  
  15088         38695  
  15088         21439  
  15088         45598  
  15088         35346  
  15088         33921  
  15088         20910  
  15088         39264  
  15088         38544  
  15088         35347  
  15088         23017  
  15088         42212  
  15088         37319  
  15088         33578  
  15088         21628  
  15088         35054  
  15088         31368  
  15088         32405  
  15088         21339  
  15088         34500  
  15088         23478  
1622              
1623 15088         265398 my $r = $self->_regexp_word;
1624 15088 100       338933 if ( $r->regexp_exec( $self, $input, $pos ) == $pos ) {
1625 3091         42594 my $lposp = $r->regexp_lpos;
1626 3091         10520 my $rposp = $r->regexp_rpos;
1627 3091         16072 my $lpos;
1628             my $lposFull;
1629 3091         0 my $rpos;
1630 3091         0 my $rposFull;
1631              
1632 3091 100       4910 if ( $#{$lposp} > 0 ) {
  3091         10887  
1633 12         34 $lpos = $lposp->[1];
1634 12         32 $rpos = $rposp->[1];
1635 12 50       45 if ( $rpos <= $lpos ) {
1636 0         0 $lpos = $lposFull = $lposp->[0];
1637 0         0 $rpos = $rposFull = $rposp->[0];
1638             }
1639             else {
1640 12         37 $lposFull = $lposp->[0];
1641 12         31 $rposFull = $rposp->[0];
1642             }
1643             }
1644             else {
1645 3079         8339 $lpos = $lposFull = $lposp->[0];
1646 3079         6787 $rpos = $rposFull = $rposp->[0];
1647             }
1648              
1649 3091         6294 my $lexemeLength = $rposFull - $lposFull;
1650 3091         13509 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     60717 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         330 my $lengthFull = $rposFull - $lposFull;
1676 19         89 foreach ( 1 .. $lengthFull - 1 ) {
1677 61         540 my $substring = substr( $input, $lposFull, $_ );
1678 61 100       1047 if ( $r->regexp_exec( $self, $substring, 0 ) != 0 ) {
1679 2         39 return false;
1680             }
1681             }
1682             }
1683 3089         51231 ${$lexemeLengthRef} = $lexemeLength;
  3089         6612  
1684 3089         5658 ${$lexemeValueRef} = $lexemeValue;
  3089         5723  
1685 3089         10219 return true;
1686             }
1687              
1688 11997         148773 return false;
1689             }
1690              
1691 1 50   1   5645 method parser_isComment (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   23996   2  
  1 50       153  
  1 50       6  
  1 50       2  
  1 50       124  
  1 50       6  
  1 50       2  
  1 50       114  
  1 50       6  
  1 50       2  
  1 50       108  
  1 50       6  
  1 50       1  
  1 50       116  
  1 50       5  
  1 50       2  
  1         344  
  1         2466  
  23996         282339  
  23996         59282  
  23996         61963  
  23996         54316  
  23996         33204  
  23996         64546  
  23996         52203  
  23996         68997  
  23996         42313  
  23996         60389  
  23996         60161  
  23996         53757  
  23996         39142  
  23996         58372  
  23996         50503  
  23996         55524  
  23996         42086  
  23996         57317  
  23996         51065  
  23996         47747  
  23996         36548  
  23996         52393  
  23996         34754  
1692              
1693             #
1694             # We want to catch EOF in comment. So we do it ourself.
1695             #
1696 23996         412529 my $comStart = $self->_comment_start;
1697 23996         492235 my $comEnd = $self->_comment_end;
1698 23996         464043 my $commentStartLength = $self->_commentStartLength;
1699 23996         454283 my $commentEndLength = $self->_commentEndLength;
1700 23996 100 66     232228 if ( $commentStartLength > 0 && $commentEndLength > 0 ) {
1701              
1702 23916 100       214423 if ( substr( $input, $pos, $commentStartLength ) eq $comStart ) {
1703 81         186 my $lastPos = $pos + $commentStartLength;
1704 81         257 while ( $lastPos <= $maxPos ) {
1705 3075 100       5011 if ( substr( $input, $lastPos, $commentEndLength ) eq $comEnd ) {
1706 79         185 $lastPos += $commentEndLength;
1707 79         184 ${$lexemeLengthRef} = $lastPos - $pos;
  79         200  
1708 79         211 ${$lexemeValueRef}
1709 79         168 = substr( $input, $pos, ${$lexemeLengthRef} );
  79         221  
1710 79         357 return true;
1711             }
1712             else {
1713 2996         4730 ++$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         36 $self->impl_raiseException('EOF in comment');
1721             }
1722             }
1723             }
1724 23915         67916 return false;
1725             }
1726              
1727 1 50   1   5593 method parser_isQuotedstring (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   21736   3  
  1 50       149  
  1 50       6  
  1 50       2  
  1 50       118  
  1 50       5  
  1 50       2  
  1 50       147  
  1 50       10  
  1 50       2  
  1 50       127  
  1 50       12  
  1 50       2  
  1 50       145  
  1 50       6  
  1 50       3  
  1         431  
  1         2423  
  21736         195801  
  21736         50352  
  21736         57794  
  21736         44394  
  21736         31542  
  21736         61044  
  21736         45962  
  21736         44633  
  21736         39436  
  21736         59381  
  21736         46512  
  21736         43245  
  21736         28646  
  21736         52938  
  21736         42297  
  21736         54746  
  21736         32367  
  21736         57090  
  21736         41761  
  21736         39518  
  21736         27984  
  21736         42540  
  21736         32213  
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         382048 my $quoteStart = $self->_quote_start;
1734 21736         460595 my $quoteEnd = $self->_quote_end;
1735 21736         423786 my $quoteStartLength = $self->_quoteStartLength;
1736 21736         419694 my $quoteEndLength = $self->_quoteEndLength;
1737 21736 100 66     208495 if ( $quoteStartLength > 0 && $quoteEndLength > 0 ) {
1738              
1739 21716 100       212424 if ( substr( $input, $pos, $quoteStartLength ) eq $quoteStart ) {
1740 4394         8508 my $nested = 0;
1741 4394         9293 my $lastPos = $pos + $quoteStartLength;
1742 4394         11302 while ( $lastPos <= $maxPos ) {
1743 48304 100       97942 if (substr( $input, $lastPos, $quoteEndLength ) eq
    100          
1744             $quoteEnd )
1745             {
1746 7218         11580 $lastPos += $quoteEndLength;
1747 7218 100       16893 if ( $nested == 0 ) {
1748 4392         8308 ${$lexemeLengthRef} = $lastPos - $pos;
  4392         8566  
1749 4392         37526 ${$lexemeValueRef} = $self->impl_unquote(
1750 4392         8082 substr( $input, $pos, ${$lexemeLengthRef} ) );
  4392         82806  
1751 4392         18833 return true;
1752             }
1753             else {
1754 2826         4855 $nested--;
1755             }
1756             }
1757             elsif (
1758             substr( $input, $lastPos, $quoteStartLength ) eq
1759             $quoteStart )
1760             {
1761 2826         4000 $lastPos += $quoteStartLength;
1762 2826         4881 $nested++;
1763             }
1764             else {
1765 38260         61355 ++$lastPos;
1766             }
1767             }
1768             #
1769             # If we are here, it is an error if End-Of-Input is flagged
1770             #
1771 2 50       14 if ( $self->_eof ) {
1772 2         50 $self->impl_raiseException('EOF in string');
1773             }
1774             }
1775             }
1776 17342         50910 return false;
1777             }
1778              
1779 1 50   1   5502 method parser_isCharacter (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Ref $lexemeValueRef, Ref $lexemeLengthRef --> Bool) {
  1 50   7638   3  
  1 50       151  
  1 50       6  
  1 50       2  
  1 50       151  
  1 50       6  
  1 50       2  
  1 50       106  
  1 50       5  
  1 50       3  
  1 50       105  
  1 50       6  
  1 50       1  
  1 50       117  
  1 50       6  
  1 50       1  
  1         201  
  1         2320  
  7638         70459  
  7638         19183  
  7638         27898  
  7638         19062  
  7638         11175  
  7638         20853  
  7638         19285  
  7638         15796  
  7638         10762  
  7638         21787  
  7638         16436  
  7638         19061  
  7638         10397  
  7638         19396  
  7638         17374  
  7638         19543  
  7638         11164  
  7638         18620  
  7638         17392  
  7638         16447  
  7638         12147  
  7638         18527  
  7638         11627  
1780 7638         141256 pos($input) = $pos;
1781 7638 50       67054 if ( $input =~ /\G./s ) {
1782 7638         248982 ${$lexemeLengthRef} = $+[0] - $-[0];
  7638         16336  
1783 7638         72655 ${$lexemeValueRef} = substr( $input, $-[0], ${$lexemeLengthRef} );
  7638         12311  
  7638         73498  
1784 7638         25935 return true;
1785             }
1786 0         0 return false;
1787             }
1788              
1789 1 50   1   2172 method _getMacro (Str $word --> M4Macro) {
  1 50   2533   2  
  1 50       169  
  1 50       8  
  1 50       2  
  1         92  
  1         2367  
  2533         29101  
  2533         8129  
  2533         8677  
  2533         8002  
  2533         4262  
  2533         8462  
  2533         4476  
1790 2533         43195 return $self->_macros_get($word)->macros_get(-1);
1791             }
1792              
1793 1 50   1   7304 method parser_isMacro (Str $input, PositiveOrZeroInt $pos, PositiveOrZeroInt $maxPos, Str $wordValue, PositiveInt $wordLength, Ref $macroRef, Ref $lparenPosRef --> Bool) {
  1 50   3089   3  
  1 50       171  
  1 50       7  
  1 50       2  
  1 50       127  
  1 50       7  
  1 50       2  
  1 50       109  
  1 50       7  
  1 50       2  
  1 50       109  
  1 50       5  
  1 50       2  
  1 50       114  
  1 50       6  
  1 50       3  
  1 50       97  
  1 50       6  
  1 50       3  
  1 50       104  
  1 50       6  
  1 50       2  
  1         277  
  1         2489  
  3089         33827  
  3089         9978  
  3089         13162  
  3089         8825  
  3089         5096  
  3089         11380  
  3089         8845  
  3089         10224  
  3089         7866  
  3089         10921  
  3089         10842  
  3089         8854  
  3089         6368  
  3089         9804  
  3089         10105  
  3089         8781  
  3089         6096  
  3089         9331  
  3089         9319  
  3089         10228  
  3089         5609  
  3089         10895  
  3089         10377  
  3089         8653  
  3089         5287  
  3089         8228  
  3089         10316  
  3089         9509  
  3089         5683  
  3089         9288  
  3089         5628  
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       61377 if ( $self->_macros_exists($wordValue) ) {
1800 2443         177591 my $macro = $self->_getMacro($wordValue);
1801 2443         555823 my $lparenPos = $pos + $wordLength;
1802 2443         5246 my $dummy;
1803 2443 100 100     42334 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     84702 if ( $lparen eq '(' || !$macro->macro_needParams ) {
1814 2441         20170 ${$macroRef} = $macro;
  2441         5535  
1815 2441 100       6784 ${$lparenPosRef} = ( $lparen eq '(' ) ? $lparenPos : -1;
  2441         4050  
1816 2441         8977 return true;
1817             }
1818             }
1819              
1820 648         34578 return false,;
1821             }
1822              
1823 1 50   1   1119 method parser_tokensPriority {
  1     2017   2  
  1         84  
  1         2315  
  2017         7617  
  2017         4790  
1824 2017         45334 return $self->_tokens_priority_elements;
1825             }
1826              
1827             # ---------------------------------------------------------------
1828             # LOGGER REQUIRED METHODS
1829             # ---------------------------------------------------------------
1830 1 50   1   2227 method logger_error (@args --> Undef) {
  1 50   40   3  
  1         140  
  1         224  
  40         2584  
  40         341  
  40         108  
1831             #
1832             # Localize anyway, because there can be an error within
1833             # new_with_options() -;
1834             #
1835 40         149 local $MarpaX::Languages::M4::SELF = $self;
1836 40         808 $self->_logger->errorf(@args);
1837 40         19303 return;
1838             }
1839              
1840 1 50   1   1890 method logger_warn (@args --> Undef) {
  1 50   28   1  
  1         244  
  1         2131  
  28         1429  
  28         189  
  28         69  
1841             #
1842             # Localize anyway, because there can be an error within
1843             # new_with_options() -;
1844             #
1845 28         89 local $MarpaX::Languages::M4::SELF = $self;
1846 28 50       213 if ( !$self->silent ) {
1847 28         585 $self->_logger->warnf(@args);
1848             }
1849 28 100       17722 if ( $self->_fatal_warnings >= 1 ) {
1850 2         63 $self->_set__rc(EXIT_FAILURE);
1851             }
1852 28 100       1426 if ( $self->_fatal_warnings > 1 ) {
1853             #
1854             # Say we do not accept more input
1855             #
1856 2         49 $self->impl_setEoi;
1857 2         46 $self->impl_raiseException('Warning is fatal');
1858             }
1859 26         321 return;
1860             }
1861              
1862 1 50   1   2187 method _canDebug (Str $what --> Bool) {
  1 50   116   2  
  1 50       145  
  1 50       6  
  1 50       2  
  1         79  
  1         2235  
  116         1454  
  116         328  
  116         347  
  116         294  
  116         208  
  116         327  
  116         235  
1863             #
1864             # A macro is debugged if 't' is setted,
1865             # or if it is explicitely traced
1866             #
1867 116         1935 return $self->_debug_get($what);
1868             }
1869              
1870 1 50 33 1   2948 method _canTrace (ConsumerOf[M4Macro] $macro --> Bool) {
  1 50   2450   2  
  1 50       153  
  1 50       6  
  1 50       2  
  1 50       189  
  1         2114  
  2450         29451  
  2450         7119  
  2450         7491  
  2450         7125  
  2450         4207  
  2450         3855  
  2450         12180  
  2450         14117  
  2450         8936  
  2450         54898  
1871             #
1872             # A macro is debugged if 't' is setted,
1873             # or if it is explicitely traced
1874             #
1875 2450 50 33     49154 if ( !$self->_debug_get('t') && !$self->_trace_get( $macro->name ) ) {
1876 2450         511148 return false;
1877             }
1878              
1879 0         0 return true;
1880             }
1881              
1882 1 50   1   1880 method logger_debug (@args --> Undef) {
  1 50   3   3  
  1         134  
  1         2100  
  3         215  
  3         20  
  3         9  
1883 3         10 local $MarpaX::Languages::M4::SELF = $self;
1884 3         52 $self->_logger->debugf(@args);
1885 3         1546 return;
1886             }
1887              
1888             #
1889             # _canTrace is called upper
1890             #
1891 1 0   1   1932 method logger_trace (@args --> Undef) {
  1 0   0   2  
  1         263  
  1         2211  
  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         2098 has _lastSysExitCode => ( is => 'rw', isa => Int, default => 0 );
1901              
1902 1         1828 has __file__ => ( is => 'rwp', isa => Str, default => '' );
1903 1         1576 has __line__ => ( is => 'rwp', isa => PositiveOrZeroInt, default => 0 );
1904              
1905             # Saying directly $0 failed in taint mode
1906 1         1280 has __program__ => ( is => 'rwp', isa => Str, default => sub {$0} );
  140         7048  
1907              
1908 1         1365 has _value => (
1909             is => 'rwp',
1910             isa => Str,
1911             default => ''
1912             );
1913              
1914             # ----------------------------------------------------
1915             # builders
1916             # ----------------------------------------------------
1917              
1918 1 0   1   1048 method _build_quote_start {$DEFAULT_QUOTE_START}
  1     0   3  
  1         80  
  1         1487  
  0         0  
  0         0  
  0         0  
1919              
1920 1 50   1   1028 method _build__logger_category {'M4'}
  1     34   2  
  1         72  
  1         283  
  34         1740  
  34         111  
  34         589  
1921              
1922             #
1923             # Diversion 0 is special and maps directly to an internal variable
1924             #
1925 1 50   1   1017 method _build__diversions { { 0 => IO::Scalar->new } }
  1     140   2  
  1         82  
  1         175  
  140         4795  
  140         279  
  140         1279  
1926              
1927 1 50   1   1010 method _build__lastDiversion { $self->_diversions_get(0) }
  1     118   2  
  1         79  
  1         171  
  118         1799  
  118         228  
  118         2375  
1928              
1929 1 50   1   1008 method _build__builtins {
  1     138   3  
  1         888  
  1         236  
  138         4088  
  138         326  
1930 138         318 my %ref = ();
1931 138         853 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     99617 if ( $self->_no_gnu_extensions
      66        
1959             && exists( $Default_EXTENSIONS{$_} )
1960             && $Default_EXTENSIONS{$_} )
1961             {
1962 10         119 next;
1963             }
1964 6200         54377 my $stubName = "builtin_$_";
1965 6200         106674 $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       294231 if ( $self->_builtin_need_param_exists($_) ) {
1979 3995         233585 $ref{$_}->needParams( $self->_builtin_need_param_get($_) );
1980             }
1981 6200 100       646595 if ( $self->_param_can_be_macro_exists($_) ) {
1982 550         40514 $ref{$_}
1983             ->paramCanBeMacro( $self->_param_can_be_macro_get($_) );
1984             }
1985 6200 100       316085 if ( $_ eq 'dnl' ) {
1986             $ref{$_}->postMatchLength(
1987             sub {
1988 128     128   6092 my ( $self, $input, $pos, $maxPos ) = @_;
1989 128         750 pos($input) = $pos;
1990 128 100 33     1252 if ( $input =~ /\G.*?\n/s ) {
    50          
1991 127         1177 return $+[0] - $-[0];
1992             }
1993             elsif ( $self->_eof && $input =~ /\G[^\n]*\z/ ) {
1994 1         26 $self->logger_warn( '%s: %s',
1995             'dnl', 'EOF without a newline' );
1996 1         8 return $+[0] - $-[0];
1997             }
1998             else {
1999 0         0 return 0;
2000             }
2001             }
2002 138         3438 );
2003             }
2004             }
2005 138 100       2353 if ( !$self->_no_gnu_extensions ) {
2006 137         1258 my $name = '__gnu__';
2007             $ref{$name} = MarpaX::Languages::M4::Impl::Macro->new(
2008             name => $name,
2009             expansion => '',
2010 2     2   102 stub => sub { return ''; }
2011 137         2950 );
2012             }
2013 138 50       5497 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       3761 if ( is_os_type('Unix') ) {
2031 138 100       3958 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         3721 );
2037             }
2038              
2039 138         6884 return \%ref;
2040             }
2041              
2042 1 50   1   992 method _build__macros {
  1     138   2  
  1         160  
  1         178  
  138         4479  
  138         264  
2043 138         298 my %ref = ();
2044 138         2546 foreach ( $self->_builtins_keys ) {
2045 6475         384080 my $macros = MarpaX::Languages::M4::Impl::Macros->new();
2046 6475         247015 $macros->macros_push( $self->_builtins_get($_) );
2047 6475         1010583 $ref{ $self->_prefix_builtins . $_ } = $macros;
2048             }
2049 138         4295 return \%ref;
2050             }
2051              
2052             # ----------------------------------------------------
2053             # Triggers
2054             # ----------------------------------------------------
2055 1 50   1   2785 method _trigger__eoi (Bool $eoi, @rest --> Undef) {
  1 50   142   2  
  1 50       148  
  1 50       6  
  1 50       2  
  1 50       596  
  1         167  
  142         13564  
  142         531  
  142         577  
  142         612  
  142         277  
  142         597  
  142         610  
  142         365  
2056 142 50       478 if ($eoi) {
2057             #
2058             # First, m4wrap stuff is rescanned.
2059             # and each of them appears like an
2060             # independant input.
2061             #
2062 142         2629 while ( $self->_m4wrap_count > 0 ) {
2063 21         1407 my @m4wrap = $self->_m4wrap_elements;
2064 21         1238 $self->_set___m4wrap( [] );
2065 21 50       1006 $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         10008 $self->builtin_divert();
2076 142         2918 $self->builtin_undivert();
2077             }
2078 142         676 return;
2079             }
2080              
2081             # ----------------------------------------------------
2082             # Internal attributes
2083             # ----------------------------------------------------
2084 1         2516 has _macroCallId => (
2085             is => 'rwp',
2086             isa => PositiveOrZeroInt,
2087             default => 0
2088             );
2089              
2090 1         1554 has _rc => (
2091             is => 'rwp',
2092             isa => Int,
2093             default => EXIT_SUCCESS,
2094             );
2095              
2096 1         1378 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         7113 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         2320106 default => sub { [] },
2126 1         6182 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         4187 has _eof => (
2136             is => 'rwp',
2137             isa => Bool,
2138             default => false
2139             );
2140              
2141 1         1441 has _eoi => (
2142             is => 'rwp',
2143             isa => Bool,
2144             trigger => 1,
2145             default => false
2146             );
2147              
2148 1         1501 has _unparsed => (
2149             is => 'rwp',
2150             isa => Str,
2151             default => ''
2152             );
2153              
2154 1         1390 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         6859 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         15610 default => sub { [0] },
2177 1         2896 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   2190 method impl_quote (Str $string --> Str) {
  1 50   1377   3  
  1 50       148  
  1 50       6  
  1 50       2  
  1         135  
  1         4932  
  1377         15701  
  1377         4035  
  1377         3563  
  1377         3340  
  1377         1951  
  1377         4440  
  1377         2662  
2187 1377 50 33     21802 if ( $self->_quoteStartLength > 0 && $self->_quoteEndLength > 0 ) {
2188 1377         55300 return $self->_quote_start . $string . $self->_quote_end;
2189             }
2190             else {
2191 0         0 return $string;
2192             }
2193             }
2194              
2195 1 50   1   2228 method impl_unquote (Str $string --> Str) {
  1 50   4392   2  
  1 50       147  
  1 50       6  
  1 50       2  
  1         149  
  1         2025  
  4392         43672  
  4392         10643  
  4392         20292  
  4392         11522  
  4392         8388  
  4392         12210  
  4392         7049  
2196 4392 50 33     66726 if ( $self->_quoteStartLength > 0 && $self->_quoteEndLength > 0 ) {
2197 4392         169717 substr( $string, 0, $self->_quoteStartLength, '' );
2198 4392         94055 my $quoteEndLength = $self->_quoteEndLength;
2199 4392         36863 substr( $string, -$quoteEndLength, $quoteEndLength, '' );
2200             }
2201 4392         68707 return $string;
2202             }
2203              
2204 1 50   1   2691 method _checkIgnored (Str $name, @ignored --> Undef) {
  1 50   1457   2  
  1 50       152  
  1 50       6  
  1 50       2  
  1 100       142  
  1         1865  
  1457         16232  
  1457         5242  
  1457         5408  
  1457         5270  
  1457         3567  
  1457         4832  
  1457         4719  
  1457         2855  
2205 1457 100       5223 if (@ignored) {
2206 2         40 $self->logger_warn( 'excess arguments to builtin %s ignored',
2207             $self->impl_quote($name) );
2208             }
2209 1457         3143 return;
2210             }
2211              
2212 1 50 66 1   6186 method builtin_define (Undef|Str|M4Macro $name?, Undef|Str|M4Macro $defn?, @ignored --> Str) {
  1 50 66 314   2  
  1 50       139  
  1 50       6  
  1 50       2  
  1 50       200  
  1 50       5  
  1 50       3  
  1         436  
  1         2141  
  314         24717  
  314         1468  
  314         1307  
  314         603  
  314         2748  
  314         1663  
  314         1158  
  314         632  
  314         2081  
  314         1312  
  314         663  
2213 314 50       1099 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     3895 $defn //= '';
2221              
2222 314         6556 $self->_checkIgnored( 'define', @ignored );
2223              
2224 314 100       1116 if ( M4Macro->check($name) ) {
2225 2         146 $self->logger_warn(
2226             '%s: invalid macro name ignored',
2227             $self->impl_quote('define')
2228             );
2229 2         56 return '';
2230             }
2231              
2232 312         4104 my $macro;
2233 312 100       1409 if ( Str->check($defn) ) {
2234             #
2235             # Make a M4Macro out of $defn
2236             #
2237 307         8416 $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       21067 if ( !$self->_macros_exists($name) ) {
2247 192         15715 my $macros = MarpaX::Languages::M4::Impl::Macros->new();
2248 192         10173 $macros->macros_push($macro);
2249 192         13537 $self->_macros_set( $name, $macros );
2250             }
2251             else {
2252 118         9179 $self->_macros_get($name)->macros_set( -1, $macro );
2253             }
2254 310         52992 return '';
2255             }
2256              
2257 1 50   1   2306 method builtin_undefine (Str @names --> Str) {
  1 50   9   2  
  1 50       129  
  1         6  
  1         3  
  1         98  
  1         1833  
  9         648  
  9         56  
  9         29  
  10         24  
  10         52  
  9         25  
2258 9         230 $self->_macros_delete(@names);
2259 9         1446 return '';
2260             }
2261              
2262             #
2263             # defn can only concatenate text macros
2264             #
2265 1 50   1   2750 method builtin_defn (Str @names --> Str|M4Macro) {
  1 50   74   2  
  1 50       129  
  1         7  
  1         2  
  1         337  
  1         1725  
  74         5978  
  74         446  
  74         327  
  78         158  
  78         385  
  74         143  
2266 74         189 my @macros = ();
2267              
2268 74         213 foreach (@names) {
2269 78 50       2795 if ( $self->_macros_exists($_) ) {
2270 78         5509 push( @macros, $self->_getMacro($_) );
2271             }
2272             }
2273              
2274 74         17544 my $rc = '';
2275 74         411 foreach ( 0 .. $#macros ) {
2276 78 100       1809 if ( $macros[$_]->macro_isBuiltin ) {
2277 18 100 100     1294 if ( ( $_ == 0 && $#macros > 0 )
      100        
2278             || ( $_ > 0 ) )
2279             {
2280 3         79 $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         71 $rc = $macros[$_];
2291             }
2292             }
2293             else {
2294 60         4211 $rc .= $self->impl_quote( $macros[$_]->macro_expansion );
2295             }
2296             }
2297 74         3924 return $rc;
2298             }
2299              
2300 1 50 66 1   5554 method builtin_pushdef (Undef|Str $name?, Undef|Str|M4Macro $defn?, @ignored --> Str) {
  1 50   66   2  
  1 50       145  
  1 50       6  
  1 100       2  
  1 50       114  
  1 100       6  
  1 50       2  
  1         391  
  1         7313  
  66         5052  
  66         345  
  66         342  
  66         164  
  66         510  
  66         386  
  66         348  
  59         133  
  59         592  
  66         366  
  66         184  
2301 66 50       284 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         783 my $macro;
2310 66   100     296 $defn //= '';
2311              
2312 66         1468 $self->_checkIgnored( 'pushdef', @ignored );
2313              
2314 66 100       279 if ( Str->check($defn) ) {
2315             #
2316             # Make a M4Macro out of $defn
2317             #
2318 63         1821 $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         78 $macro = $defn->macro_clone($name);
2326             }
2327 66 100       4867 if ( !$self->_macros_exists($name) ) {
2328 30         2316 my $macros = MarpaX::Languages::M4::Impl::Macros->new();
2329 30         1521 $macros->macros_push($macro);
2330 30         1961 $self->_macros_set( $name, $macros );
2331             }
2332             else {
2333 36         2606 $self->_macros_get($name)->macros_push($macro);
2334             }
2335 66         10970 return '';
2336             }
2337              
2338 1 50   1   2330 method builtin_popdef (Str @names --> Str) {
  1 50   51   2  
  1 50       128  
  1         6  
  1         2  
  1         194  
  1         1913  
  51         4085  
  51         386  
  51         181  
  54         147  
  54         325  
  51         133  
2339              
2340 51         168 foreach (@names) {
2341 54 50       1561 if ( $self->_macros_exists($_) ) {
2342 54         3723 $self->_macros_get($_)->macros_pop();
2343 54 100       10293 if ( $self->_macros_get($_)->macros_isEmpty ) {
2344 26         4162 $self->_macros_delete($_);
2345             }
2346             }
2347             }
2348 51         6885 return '';
2349             }
2350              
2351 1 50 66 1   4222 method builtin_indir (Undef|Str|M4Macro $name, @args --> Str|M4Macro) {
  1 50   10   3  
  1 50       150  
  1 50       7  
  1 50       1  
  1 100       439  
  1         1870  
  10         1050  
  10         63  
  10         50  
  10         55  
  10         29  
  10         114  
  10         87  
  10         29  
2352 10 50       47 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       181 if ( M4Macro->check($name) ) {
2363 1         48 $self->logger_warn(
2364             'indir: invalid macro name ignored',
2365             $self->impl_quote( $name->macro_name )
2366             );
2367 1         27 return '';
2368             }
2369 9 100       354 if ( $self->_macros_exists($name) ) {
2370 7         630 my $macro = $self->_getMacro($name);
2371             #
2372             # Check the args
2373             #
2374 7         1892 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         28 $args[$_] = '';
2382             }
2383             }
2384             #
2385             # macro executed by indir is not traced
2386             #
2387 7         215 return $macro->macro_execute( $self, @args );
2388              
2389             # return $self->impl_macroExecute( $macro, @args );
2390             }
2391             else {
2392 2         261 $self->logger_error( 'indir: undefined macro %s',
2393             $self->impl_quote($name) );
2394 2         46 return '';
2395             }
2396             }
2397              
2398 1 50 33 1   4565 method builtin_builtin (Undef|Str|M4Macro $name?, @args --> Str|M4Macro) {
  1 100   16   3  
  1 50       145  
  1 100       7  
  1 100       2  
  1         472  
  1         7324  
  16         1451  
  16         89  
  16         81  
  15         38  
  15         212  
  16         106  
  16         45  
2399 16 100       77 if ( Undef->check($name) ) {
2400 1         46 $self->logger_error(
2401             'too few arguments to builtin %s',
2402             $self->impl_quote('builtin')
2403             );
2404 1         38 return '';
2405             }
2406 15 50       241 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       564 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         805 my $rc = '';
2422             try {
2423 11     11   866 $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         150 };
2430 11         810 return $rc;
2431             }
2432             else {
2433 4         374 $self->logger_error( 'builtin: undefined builtin %s',
2434             $self->impl_quote($name) );
2435 4         116 return '';
2436             }
2437             }
2438              
2439 1 50   1   6568 method builtin_ifdef (Undef|Str $name?, Undef|Str $string1?, Undef|Str $string2?, @ignored --> Str) {
  1 50   62   2  
  1 50       139  
  1 50       6  
  1 50       2  
  1 50       114  
  1 50       6  
  1 100       2  
  1 50       108  
  1 100       6  
  1 100       2  
  1         226  
  1         7553  
  62         4912  
  62         325  
  62         295  
  62         215  
  62         437  
  62         293  
  62         278  
  62         142  
  62         319  
  62         298  
  62         376  
  19         46  
  19         93  
  62         272  
  62         171  
2440 62 50 33     270 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         2546 $self->_checkIgnored( 'ifdef', @ignored );
2449              
2450 62 100       1274 if ( $self->_macros_exists($name) ) {
2451 41         3078 return $string1;
2452             }
2453             else {
2454 21   100     1595 return $string2 // '';
2455             }
2456             }
2457              
2458 1 50   1   1901 method builtin_ifelse (@args --> Str) {
  1 50   252   2  
  1         394  
  1         2238  
  252         20277  
  252         1983  
  252         1028  
2459 252         1581 while (@args) {
2460 293 100 66     3623 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         27 return '';
2469             }
2470             elsif ( scalar(@args) >= 3 && scalar(@args) <= 5 ) {
2471 246         1134 my ( $string1, $string2, $equal, $notEqual, $ignored )
2472             = @args;
2473 246   50     1124 $string1 //= '';
2474 246   50     939 $string2 //= '';
2475 246   50     1114 $equal //= '';
2476 246   100     1048 $notEqual //= '';
2477 246 100       1348 if ( !Undef->check($ignored) ) {
2478 2         68 $self->logger_warn(
2479             'excess arguments to builtin %s ignored',
2480             $self->impl_quote('ifelse') );
2481             }
2482 246 100       7613 return ( $string1 eq $string2 ) ? $equal : $notEqual;
2483             }
2484             else {
2485 45         209 my ( $string1, $string2, $equal, @rest ) = @args;
2486 45   50     204 $string1 //= '';
2487 45   50     186 $string2 //= '';
2488 45   50     191 $equal //= '';
2489 45 100       204 if ( $string1 eq $string2 ) {
2490 4         86 return $equal;
2491             }
2492 41         254 @args = @rest;
2493             }
2494             }
2495             }
2496              
2497 1 50   1   1883 method builtin_shift (@args --> Str) {
  1 50   151   3  
  1         212  
  1         2005  
  151         12293  
  151         999  
  151         344  
2498 151         344 shift(@args);
2499              
2500 151 100       755 if (@args) {
2501 133         554 return join( ',', map { $self->impl_quote($_) } @args );
  448         20728  
2502             }
2503             else {
2504 18         312 return '';
2505             }
2506             }
2507              
2508 1 50   1   1861 method builtin_dumpdef (@args --> Str) {
  1 50   4   2  
  1         275  
  1         1897  
  4         320  
  4         29  
  4         9  
2509              
2510 4 50       20 if ( !@args ) {
2511 0         0 @args = $self->_macros_keys;
2512             }
2513              
2514 4         25 foreach ( sort @args ) {
2515 4 100       107 if ( !$self->_macros_exists($_) ) {
2516 1         126 $self->logger_warn( 'dumpdef: undefined macro %s',
2517             $self->impl_quote($_) );
2518             }
2519             else {
2520 3 100       212 $self->logger_debug(
2521             '%s: %s',
2522             $_,
2523             $self->_getMacro($_)->macro_isBuiltin
2524             ? "<$_>"
2525             : $self->_getMacro($_)->macro_expansion
2526             );
2527             }
2528             }
2529              
2530 4         103 return '';
2531             }
2532              
2533 1 0   1   1874 method builtin_traceon (@names --> Str) {
  1 0   0   2  
  1         159  
  1         1995  
  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   1887 method builtin_traceoff (@names --> Str) {
  1 0   0   2  
  1         156  
  1         2012  
  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   3791 method builtin_debugmode (Undef|Str $flags?, @ignored --> Str) {
  1 0   0   2  
  1 0       133  
  1 0       6  
  1 0       2  
  1         244  
  1         2264  
  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   3731 method builtin_debugfile (Undef|Str $file?, @ignored --> Str) {
  1 0   0   3  
  1 0       135  
  1 0       6  
  1 0       2  
  1         143  
  1         1869  
  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   1916 method builtin_dnl (@ignored --> Str) {
  1 100   128   6  
  1         122  
  1         2013  
  128         9354  
  128         593  
  128         275  
2568 128         2325 $self->_checkIgnored( 'dnl', @ignored );
2569 128         2187 return '';
2570             }
2571              
2572 1 50   1   5231 method builtin_changequote (Undef|Str $start?, Undef|Str $end?, @ignored --> Str) {
  1 100   23   2  
  1 50       142  
  1 100       9  
  1 100       3  
  1 50       113  
  1 100       7  
  1 50       2  
  1         256  
  1         1928  
  23         1820  
  23         118  
  23         110  
  17         47  
  17         119  
  23         91  
  23         137  
  17         44  
  17         69  
  23         129  
  23         56  
2573 23 100 66     78 if ( Undef->check($start) && Undef->check($end) ) {
2574 6         141 $start = $DEFAULT_QUOTE_START;
2575 6         21 $end = $DEFAULT_QUOTE_END;
2576             }
2577              
2578 23         686 $self->_checkIgnored( 'changequote', @ignored );
2579              
2580 23   50     78 $start //= '';
2581 23 100       107 if ( length($start) <= 0 ) {
2582 1         4 $end = '';
2583             }
2584             else {
2585 22   66     100 $end ||= $DEFAULT_QUOTE_END;
2586             }
2587              
2588 23         523 $self->_set__quote_start($start);
2589 23         1470 $self->_set__quote_end($end);
2590              
2591 23         1355 return '';
2592             }
2593              
2594 1 50   1   5123 method builtin_changecom (Undef|Str $start?, Undef|Str $end?, @ignored --> Str) {
  1 100   16   2  
  1 50       236  
  1 100       7  
  1 100       2  
  1 50       132  
  1 100       7  
  1 50       2  
  1         233  
  1         1959  
  16         1257  
  16         81  
  16         93  
  13         40  
  13         96  
  16         89  
  16         88  
  13         30  
  13         64  
  16         83  
  16         41  
2595 16 100 66     77 if ( Undef->check($start) && Undef->check($end) ) {
2596 3         71 $start = '';
2597 3         9 $end = '';
2598             }
2599              
2600 16         502 $self->_checkIgnored( 'changecom', @ignored );
2601              
2602 16   50     73 $start //= '';
2603 16 100       96 if ( length($start) <= 0 ) {
2604 3         11 $end = '';
2605             }
2606             else {
2607 13   66     58 $end ||= $DEFAULT_COMMENT_END;
2608             }
2609              
2610 16         374 $self->_set__comment_start($start);
2611 16         956 $self->_set__comment_end($end);
2612              
2613 16         965 return '';
2614             }
2615              
2616 1 50   1   3558 method builtin_changeword (Undef|Str $string?, @ignored --> Str) {
  1 50   11   3  
  1 50       140  
  1 50       5  
  1 50       3  
  1         172  
  1         1877  
  11         807  
  11         56  
  11         58  
  11         33  
  11         68  
  11         50  
  11         29  
2617 11 50       36 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         313 $self->_checkIgnored( 'changeword', @ignored );
2625              
2626 11         245 $self->word_regexp($string);
2627              
2628 11         179 return '';
2629             }
2630              
2631 1 50   1   1834 method builtin_m4wrap (@args --> Str) {
  1 50   22   2  
  1         168  
  1         1913  
  22         1534  
  22         149  
  22         56  
2632              
2633 22         68 my $text = join( ' ', grep { !Undef->check($_) } @args );
  22         71  
2634 22         637 $self->_m4wrap_push($text);
2635              
2636 22         1403 return '';
2637             }
2638              
2639 1 0   1   3489 method builtin_m4exit (Undef|Str $code?, @ignored --> Str) {
  1 0   0   3  
  1 0       137  
  1 0       7  
  1 0       3  
  1         315  
  1         2012  
  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   3397 method _includeFile (Bool $silent, Str $wantedFile --> Str) {
  1 50   33   3  
  1 50       154  
  1 50       6  
  1 50       3  
  1 50       123  
  1 50       5  
  1 50       2  
  1         347  
  1         1956  
  33         1069  
  33         148  
  33         156  
  33         149  
  33         74  
  33         177  
  33         183  
  33         160  
  33         78  
  33         150  
  33         90  
2674              
2675 33 100       188 if ( length($wantedFile) <= 0 ) {
2676 2 100       7 if ( !$silent ) {
2677             #
2678             # Fake a ENOENT
2679             #
2680 1 50       4 if ( exists &Errno::ENOENT ) {
2681 1         6 $! = &Errno::ENOENT;
2682 1         22 $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         37 return '';
2691             }
2692 31         101 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     677 ( exists( $ENV{M4PATH} ) && defined( $ENV{M4PATH} ) )
2699             ? M4PATH->List
2700             : ()
2701             );
2702              
2703 31         4530 my $file;
2704 31 100       725 if ( File::Spec->file_name_is_absolute($wantedFile) ) {
2705 4         17 $file = $wantedFile;
2706             }
2707             else {
2708 1     1   516 use filetest 'access';
  1         13  
  1         4  
2709 27         86 foreach (
2710 54         1752 grep { -r $_ }
2711 54         638 map { File::Spec->catfile( $_, $wantedFile ) } @includes
2712             )
2713             {
2714 25         93 $file = $_;
2715 25         59 last;
2716             }
2717             }
2718              
2719 31 100       208 if ( !$file ) {
2720             #
2721             # It is guaranteed that #includes have at least one element.
2722             # Therefore, $! should be setted
2723             #
2724 2 100       9 if ( !$silent ) {
2725 1         24 $self->logger_error( 'cannot open %s: %s',
2726             $self->impl_quote($wantedFile), $! );
2727             }
2728 2         50 return '';
2729             }
2730              
2731 29 50       701 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         3668 my $content = '';
2740 29         143 my $previousFile = $self->__file__;
2741 29         119 my $previousLine = $self->__line__;
2742 29         153 $self->impl_parseIncrementalFile( $file, $silent, false, \$content );
2743 29 50       545 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         3271 $self->_set___file__($previousFile);
2751 29         1056 $self->_set___line__($previousLine);
2752              
2753 29         1459 return $content;
2754             }
2755              
2756 1 50   1   3851 method builtin_include (Undef|Str $file, @ignored --> Str) {
  1 50   31   2  
  1 50       159  
  1 50       6  
  1 50       2  
  1 50       210  
  1         1985  
  31         2184  
  31         168  
  31         145  
  31         159  
  31         82  
  31         212  
  31         167  
  31         84  
2757 31 50       121 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         878 $self->_checkIgnored( 'include', @ignored );
2765              
2766 31         149 return $self->_includeFile( false, $file );
2767             }
2768              
2769 1 50   1   3667 method builtin_sinclude (Undef|Str $file, @ignored --> Str) {
  1 50   2   2  
  1 50       154  
  1 50       6  
  1 50       2  
  1 50       239  
  1         2100  
  2         121  
  2         7  
  2         7  
  2         6  
  2         4  
  2         11  
  2         6  
  2         4  
2770 2 50       5 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         50 $self->_checkIgnored( 'sinclude', @ignored );
2778              
2779 2         7 return $self->_includeFile( true, $file );
2780             }
2781              
2782 1 50 33 1   4309 method _apply_diversion (Int $number, ConsumerOf ['IO::Handle'] $fh --> Undef) {
  1 50 33 218   2  
  1 50       151  
  1 50       7  
  1 50       2  
  1 50       186  
  1 50       6  
  1 50       2  
  1 50       248  
  1         1863  
  218         2845  
  218         1139  
  218         987  
  218         843  
  218         540  
  218         2777  
  218         1000  
  218         942  
  218         449  
  218         367  
  218         1263  
  218         1362  
  218         1797  
  218         625  
2783             my $index
2784 246     246   13051 = $self->_lastDiversionNumbers_first_index( sub { $_ == $number }
2785 218         5008 );
2786 218 100       1238 if ( $index >= 0 ) {
2787 185         3533 $self->_lastDiversionNumbers_splice( $index, 1 );
2788             }
2789 218         22866 $self->_lastDiversionNumbers_push($number);
2790 218 100       13508 if ( !$self->_diversions_exists($number) ) {
2791 33         2130 $self->_diversions_set( $number, $fh );
2792             }
2793 218         14457 $fh->autoflush(1);
2794 218         4396 $self->_set__lastDiversion($fh);
2795              
2796 218         9334 return;
2797             }
2798              
2799 1 50 33 1   2243 method _remove_diversion (Int $number --> Undef) {
  1 50   33   10  
  1 50       150  
  1 50       6  
  1 50       1  
  1         226  
  1         2323  
  33         405  
  33         149  
  33         155  
  33         140  
  33         58  
  33         421  
  33         81  
2800             my $index
2801 37     37   1564 = $self->_lastDiversionNumbers_first_index( sub { $_ == $number }
2802 33         696 );
2803 33 50       168 if ( $index >= 0 ) {
2804 33         535 $self->_lastDiversionNumbers_splice( $index, 1 );
2805 33         3275 $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         3977 $self->_set__lastDiversion(
2820             $self->_diversions_get( $self->builtin_divnum ) );
2821 33         6381 return;
2822             }
2823              
2824 1 50   1   3599 method builtin_divert (Undef|Str $number?, @ignored --> Str) {
  1 100   218   3  
  1 50       135  
  1 100       6  
  1 50       2  
  1         516  
  1         2154  
  218         7605  
  218         981  
  218         1385  
  46         127  
  46         349  
  218         1126  
  218         558  
2825 218         4221 $self->_checkIgnored( 'divert', @ignored );
2826              
2827 218   100     1293 $number //= 0;
2828 218 100       1099 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       1665 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         3059 my $fh;
2840 218 100       849 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         3665 $fh = $self->_diversions_get($number);
2847             }
2848             else {
2849 42 100       1007 if ( !$self->_diversions_exists($number) ) {
2850             #
2851             # Create diversion
2852             #
2853             try {
2854 33 50   33   2640 if ( $self->_divert_type eq 'memory' ) {
2855 33         1031 $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         4648 };
2870 33 50       2065 if ( Undef->check($fh) ) {
2871 0         0 return '';
2872             }
2873             }
2874             else {
2875             #
2876             # Get diversion $fh
2877             #
2878 9         782 $fh = $self->_diversions_get($number);
2879             }
2880             }
2881             #
2882             # Make sure latest diversion number is $number
2883             #
2884 218         25627 $self->_apply_diversion( $number, $fh );
2885 218         1736 return '';
2886             }
2887              
2888 1 50   1   1055 method _diversions_sortedKeys {
  1     145   3  
  1         111  
  1         1856  
  145         478  
  145         249  
2889 145         2706 return sort { $a <=> $b } $self->_diversions_keys;
  28         1447  
2890             }
2891              
2892 1 50   1   2265 method builtin_undivert (Str @diversions --> Str) {
  1 100   157   2  
  1 50       130  
  1         6  
  1         2  
  1         415  
  1         265  
  157         3009  
  157         664  
  157         528  
  15         28  
  15         66  
  157         320  
2893              
2894             #
2895             # Undiverting the empty string is the same as specifying diversion 0
2896             #
2897 157         825 foreach ( 0 .. $#diversions ) {
2898 15 100       88 if ( length( $diversions[$_] ) <= 0 ) {
2899 1         4 $diversions[$_] = '0';
2900             }
2901             }
2902              
2903 157 100       626 if ( !@diversions ) {
2904 145         661 @diversions = $self->_diversions_sortedKeys;
2905             }
2906              
2907 157         7288 foreach (@diversions) {
2908 186         457 my $number = $_;
2909 186 100       617 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     4958 if ( $number == $self->builtin_divnum
      100        
2915             || $number == 0
2916             || !$self->_diversions_exists($number) )
2917             {
2918 150         10445 next;
2919             }
2920             #
2921             # Only positive numbers are merged
2922             #
2923 33 100       4289 if ( $number > 0 ) {
2924             #
2925             # This is per-def a IO::Handle consumer
2926             #
2927 18         308 my $fh = $self->_diversions_get($number);
2928             #
2929             # Get its size
2930             #
2931 18         1568 $fh->seek( 0, SEEK_END );
2932 18         433 my $size = $fh->tell;
2933             #
2934             # Go to the beginning
2935             #
2936 18         132 $fh->seek( 0, SEEK_SET );
2937             #
2938             # Read it
2939             #
2940 18         236 my $content = '';
2941 18         91 $fh->read( $content, $size );
2942             #
2943             # Now we can really remove this diversion
2944             #
2945 18         704 $self->_remove_diversion($number);
2946             #
2947             # And append to the now-current diversion
2948             #
2949 18         315 $self->impl_appendValue($content);
2950             }
2951             else {
2952 15         308 $self->_remove_diversion($number);
2953             }
2954             }
2955             else {
2956             #
2957             # Treated as name of a file
2958             #
2959 3         99 $self->impl_appendValue( $self->builtin_include($number) );
2960             }
2961             }
2962              
2963 157         966 return '';
2964             }
2965              
2966 1 50   1   1870 method builtin_divnum (@ignored --> Str) {
  1 50   225   3  
  1         132  
  1         1917  
  225         3164  
  225         811  
  225         507  
2967 225         3653 $self->_checkIgnored( 'divnum', @ignored );
2968              
2969 225         4308 return $self->_lastDiversionNumbers_get(-1);
2970             }
2971              
2972 1 50   1   3483 method builtin_len (Undef|Str $string?, @ignored --> Str) {
  1 50   6   3  
  1 50       148  
  1 50       6  
  1 50       2  
  1         189  
  1         1864  
  6         509  
  6         36  
  6         36  
  6         15  
  6         47  
  6         32  
  6         14  
2973 6 50       34 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         206 $self->_checkIgnored( 'len', @ignored );
2979              
2980 6   50     29 $string //= '';
2981 6         132 return length($string);
2982             }
2983              
2984 1 50   1   4949 method builtin_index (Undef|Str $string?, Undef|Str $substring?, @ignored --> Str) {
  1 100   7   3  
  1 50       132  
  1 100       6  
  1 100       2  
  1 50       110  
  1 100       6  
  1 50       2  
  1         266  
  1         1856  
  7         602  
  7         39  
  7         38  
  6         15  
  6         46  
  7         39  
  7         50  
  5         15  
  5         22  
  7         33  
  7         21  
2985 7 100       31 if ( Undef->check($string) ) {
2986 1         58 $self->logger_error(
2987             'too few arguments to builtin %s',
2988             $self->impl_quote('index')
2989             );
2990 1         38 return '';
2991             }
2992 6 100       72 if ( Undef->check($substring) ) {
2993 1         28 $self->logger_error(
2994             'too few arguments to builtin %s',
2995             $self->impl_quote('index')
2996             );
2997 1         22 return 0;
2998             }
2999 5         141 $self->_checkIgnored( 'index', @ignored );
3000              
3001 5 50       17 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         159 return index( $string, $substring );
3007             }
3008              
3009 1 50   1   6804 method builtin_regexp (Undef|Str $string?, Undef|Str $regexpString?, Undef|Str $replacement?, @ignored --> Str) {
  1 50   29   3  
  1 50       155  
  1 50       6  
  1 100       2  
  1 50       116  
  1 100       6  
  1 100       2  
  1 50       117  
  1 100       6  
  1 50       2  
  1         394  
  1         1827  
  29         2504  
  29         162  
  29         153  
  29         75  
  29         210  
  29         143  
  29         140  
  28         87  
  28         163  
  29         135  
  29         160  
  16         44  
  16         80  
  29         160  
  29         64  
3010 29 100 66     140 if ( Undef->check($string) || Undef->check($regexpString) ) {
3011 1         42 $self->logger_error(
3012             'too few arguments to builtin %s',
3013             $self->impl_quote('regexp')
3014             );
3015 1         22 return '0';
3016             }
3017              
3018 28         1375 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
3019 28 100       1340 if (!$r->regexp_compile( $self, $self->_regexp_type, $regexpString ) )
3020             {
3021 1         55 return '';
3022             }
3023              
3024 27         1424 $self->_checkIgnored( 'regexp', @ignored );
3025              
3026 27 100       112 if ( Undef->check($replacement) ) {
3027             #
3028             # Expands to the index of first match in string
3029             #
3030 11 100       339 if ( $r->regexp_exec( $self, $string ) >= 0 ) {
3031 7         219 return $r->regexp_lpos_get(0);
3032             }
3033             else {
3034 4         145 return -1;
3035             }
3036             }
3037             else {
3038 16 100       523 if ( $r->regexp_exec( $self, $string ) >= 0 ) {
3039 14         433 return $r->regexp_substitute( $self, $string, $replacement );
3040             }
3041             else {
3042 2         60 return '';
3043             }
3044             }
3045             }
3046              
3047 1 50   1   6634 method builtin_substr (Undef|Str $string?, Undef|Str $from?, Undef|Str $length?, @ignored --> Str) {
  1 50   4   2  
  1 50       153  
  1 50       7  
  1 100       1  
  1 50       135  
  1 100       6  
  1 100       6  
  1 50       115  
  1 100       7  
  1 50       1  
  1         387  
  1         1970  
  4         378  
  4         21  
  4         22  
  4         12  
  4         33  
  4         21  
  4         19  
  3         8  
  3         15  
  4         18  
  4         21  
  1         4  
  1         9  
  4         20  
  4         10  
3048 4 50       20 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       54 if ( Undef->check($from) ) {
3056 1         27 $self->logger_error(
3057             'too few arguments to builtin %s',
3058             $self->impl_quote('substr')
3059             );
3060 1         24 return $string;
3061             }
3062 3         117 $self->_checkIgnored( 'substr', @ignored );
3063              
3064 3 100       17 if ( length($from) <= 0 ) {
3065 1         25 $self->logger_warn( '%s: empty string treated as zero',
3066             'substr' );
3067 1         2 $from = 0;
3068             }
3069              
3070 3 50       25 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       42 if ( Str->check($length) ) {
3077 1 50       13 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       41 return ( !Undef->check($length) )
3085             ? substr( $string, $from, $length )
3086             : substr( $string, $from );
3087             }
3088              
3089 1 50   1   2408 method _expandRanges (Str $range --> Str) {
  1 50   25   2  
  1 50       169  
  1 50       7  
  1 50       2  
  1         418  
  1         1937  
  25         271  
  25         81  
  25         88  
  25         98  
  25         48  
  25         89  
  25         55  
3090 25         59 my $rc = '';
3091 25         112 my @chars = split( //, $range );
3092 25         106 for (
3093             my $from = undef, my $i = 0;
3094             $i <= $#chars;
3095             $from = ord( $chars[ $i++ ] )
3096             )
3097             {
3098 56         102 my $s = $chars[$i];
3099 56 100 100     202 if ( $s eq '-' && defined($from) ) {
3100 26 100       103 my $to = ( ++$i <= $#chars ) ? ord( $chars[$i] ) : undef;
3101 26 100       104 if ( !defined($to) ) {
    100          
3102             #
3103             # Trailing dash
3104             #
3105 1         5 $rc .= '-';
3106 1         5 last;
3107             }
3108             elsif ( $from <= $to ) {
3109 23         80 while ( $from++ < $to ) {
3110 508         1088 $rc .= chr($from);
3111             }
3112             }
3113             else {
3114 2         8 while ( --$from >= $to ) {
3115 27         80 $rc .= chr($from);
3116             }
3117             }
3118             }
3119             else {
3120 30         134 $rc .= $chars[$i];
3121             }
3122             }
3123 25         476 return $rc;
3124             }
3125              
3126 1 50   1   6627 method builtin_translit (Undef|Str $string?, Undef|Str $from?, Undef|Str $to?, @ignored --> Str) {
  1 50   16   3  
  1 50       165  
  1 50       7  
  1 50       2  
  1 50       118  
  1 50       6  
  1 100       3  
  1 50       118  
  1 100       6  
  1 50       2  
  1         607  
  1         1966  
  16         1362  
  16         92  
  16         82  
  16         48  
  16         121  
  16         83  
  16         93  
  16         44  
  16         73  
  16         67  
  16         69  
  15         32  
  15         68  
  16         83  
  16         36  
3127 16 50       69 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       217 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         465 $self->_checkIgnored( 'translit', @ignored );
3142              
3143 16         59 my $fromLength = length($from);
3144 16 50       65 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     101 $to //= '';
3155 16 100       108 if ( index( $to, '-' ) >= 0 ) {
3156 11         224 $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       165 if ( index( $from, '-' ) >= 0 ) {
3166 14         240 $from = $self->_expandRanges($from);
3167             }
3168              
3169 16         135 my %map = ();
3170 16         57 my $toMaxIndice = length($to) - 1;
3171 16         49 my $ito = 0;
3172 16         106 foreach ( split( //, $from ) ) {
3173 306 100       584 if ( !exists( $map{$_} ) ) {
3174 305 100       494 if ( $ito <= $toMaxIndice ) {
3175 277         686 $map{$_} = substr( $to, $ito, 1 );
3176             }
3177             else {
3178 28         64 $map{$_} = '';
3179             }
3180             }
3181 306 100       530 if ( $ito <= $toMaxIndice ) {
3182 278         356 $ito++;
3183             }
3184             }
3185              
3186 16         65 my $rc = '';
3187 16         72 foreach ( split( //, $string ) ) {
3188 129 100       251 if ( exists( $map{$_} ) ) {
3189 47         99 $rc .= $map{$_};
3190             }
3191             else {
3192 82         130 $rc .= $_;
3193             }
3194             }
3195              
3196 16         361 return $rc;
3197             }
3198              
3199             #
3200             # Almost same thing as regexp but with a /g modifier
3201             #
3202 1 50   1   6787 method builtin_patsubst (Undef|Str $string?, Undef|Str $regexpString?, Undef|Str $replacement?, @ignored --> Str) {
  1 50   12   2  
  1 50       151  
  1 50       6  
  1 100       1  
  1 50       154  
  1 100       6  
  1 100       2  
  1 50       120  
  1 100       6  
  1 50       2  
  1         534  
  1         1888  
  12         913  
  12         55  
  12         52  
  12         29  
  12         81  
  12         55  
  12         46  
  11         23  
  11         43  
  12         88  
  12         46  
  9         22  
  9         49  
  12         49  
  12         28  
3203 12 50       47 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       128 if ( Undef->check($regexpString) ) {
3212 1         29 $self->logger_error(
3213             'too few arguments to builtin %s',
3214             $self->impl_quote('patsubst')
3215             );
3216 1         22 return $string;
3217             }
3218              
3219 11         298 my $r = MarpaX::Languages::M4::Impl::Regexp->new();
3220 11 50       431 if (!$r->regexp_compile( $self, $self->_regexp_type, $regexpString ) )
3221             {
3222 0         0 return '';
3223             }
3224              
3225 11         542 $self->_checkIgnored( 'patsubst', @ignored );
3226              
3227             #
3228             # If not supplied, default replacement is deletion
3229             #
3230 11   100     49 $replacement //= '';
3231             #
3232             # Copy of the GNU M4's algorithm
3233             #
3234 11         26 my $offset = 0;
3235 11         44 my $length = length($string);
3236 11         37 my $rc = '';
3237 11         43 while ( $offset <= $length ) {
3238 39         1233 my $matchPos = $r->regexp_exec( $self, $string, $offset );
3239 39 100       433 if ( $matchPos < 0 ) {
3240 8 50       47 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         10 $rc .= substr( $string, $offset );
3248             }
3249 8         27 last;
3250             }
3251 31 100       92 if ( $matchPos > 0 ) {
3252             #
3253             # Part of the string skipped by regexp_exec
3254             #
3255 23         74 $rc .= substr( $string, $offset, $matchPos - $offset );
3256             }
3257             #
3258             # Do substitution in string:
3259             #
3260 31         542 $rc .= $r->regexp_substitute( $self, $string, $replacement );
3261             #
3262             # Continue to the end of the match
3263             #
3264 31         652 $offset = $r->regexp_rpos_get(0);
3265             #
3266             # If the regexp matched an empty string,
3267             # advance once more
3268             #
3269 31 100       1748 if ( $r->regexp_lpos_get(0) == $offset ) {
3270              
3271 15         578 $rc .= substr( $string, $offset++, 1 );
3272             }
3273             }
3274              
3275 11         215 return $rc;
3276             }
3277              
3278 1 50   1   4170 method builtin_format (Undef|Str $format?, Str @arguments --> Str) {
  1 50   18   3  
  1 50       148  
  1 50       6  
  1 50       1  
  1 50       112  
  1         5  
  1         2  
  1         238  
  1         1908  
  18         1450  
  18         94  
  18         83  
  18         61  
  18         120  
  18         98  
  18         64  
  32         57  
  32         99  
  18         36  
3279 18 50       73 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         201 my $rc = '';
3287             try {
3288 18     18   1201 $rc = sprintf( $format, @arguments );
3289             }
3290             catch {
3291 0     0   0 $self->logger_error( 'format: %s', "$_" );
3292 0         0 return;
3293 18         220 };
3294 18         630 return $rc;
3295             }
3296              
3297 1 50   1   3925 method builtin_incr (Undef|Str $number?, Str @ignored --> Str) {
  1 50   78   2  
  1 50       138  
  1 50       7  
  1 50       2  
  1 0       112  
  1         7  
  1         2  
  1         217  
  1         1911  
  78         5282  
  78         347  
  78         358  
  78         210  
  78         546  
  78         394  
  78         291  
  0         0  
  0         0  
  78         176  
3298 78         1605 $self->_checkIgnored( 'incr', @ignored );
3299 78   50     290 $number //= '';
3300 78 100       322 if ( length($number) <= 0 ) {
3301 1         21 $self->logger_error( 'empty string treated as 0 in builtin %s',
3302             $self->impl_quote('incr') );
3303 1         3 $number = 0;
3304             }
3305 78 50       428 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         1040 my $rc = '';
3314 78 50       1746 if ( $self->_integer_type eq 'native' ) {
3315 1     1   442 use integer;
  1         12  
  1         5  
3316 0         0 $rc = $number + 1;
3317             }
3318             else {
3319 78         2556 $rc = $self->builtin_eval("$number + 1");
3320             }
3321 78         1924 return $rc;
3322             }
3323              
3324 1 50   1   4087 method builtin_decr (Undef|Str $number?, Str @ignored --> Str) {
  1 50   21   2  
  1 50       137  
  1 50       7  
  1 50       2  
  1 0       117  
  1         6  
  1         2  
  1         201  
  1         1860  
  21         1631  
  21         99  
  21         116  
  21         60  
  21         172  
  21         120  
  21         70  
  0         0  
  0         0  
  21         50  
3325 21         445 $self->_checkIgnored( 'decr', @ignored );
3326 21   50     87 $number //= '';
3327 21 100       136 if ( length($number) <= 0 ) {
3328 1         20 $self->logger_error( 'empty string treated as 0 in builtin %s',
3329             $self->impl_quote('decr') );
3330 1         33 $number = 0;
3331             }
3332 21 50       133 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         299 my $rc = '';
3341 21 50       475 if ( $self->_integer_type eq 'native' ) {
3342 1     1   7 use integer;
  1         4  
  1         4  
3343 0         0 $rc = $number - 1;
3344             }
3345             else {
3346 21         712 $rc = $self->builtin_eval("$number - 1");
3347             }
3348 21         574 return $rc;
3349             }
3350              
3351 1 50   1   7121 method builtin_eval (Undef|Str $expression?, Undef|Str $radix?, Undef|Str $width?, Str @ignored --> Str) {
  1 50   171   2  
  1 50       146  
  1 50       5  
  1 100       2  
  1 50       120  
  1 100       6  
  1 100       2  
  1 50       120  
  1 100       6  
  1 50       6  
  1 0       104  
  1         6  
  1         2  
  1         863  
  1         1841  
  171         7272  
  171         834  
  171         823  
  171         398  
  171         942  
  171         806  
  171         642  
  10         28  
  10         45  
  171         596  
  171         631  
  5         13  
  5         28  
  171         629  
  171         670  
  0         0  
  0         0  
  171         459  
3352 171 50       637 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         4866 $self->_checkIgnored( 'eval', @ignored );
3360              
3361 171 50       466 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     1804 if ( Undef->check($radix) || length($radix) <= 0 ) {
3370 163         1569 $radix = 10;
3371             }
3372 171 50       976 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     2689 if ( $radix < 1 || $radix > 36 ) {
3381 1         23 $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         21 return '';
3387             }
3388             #
3389             # Validate width
3390             #
3391 170 100 66     484 if ( Undef->check($width) || length($width) <= 0 ) {
3392 165         1492 $width = 1;
3393             }
3394 170 100       1143 if ( !PositiveOrZeroInt->check($width) ) {
3395 1         30 $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         21 return '';
3400             }
3401             #
3402             # Check expression
3403             #
3404 169 100       2026 if ( length($expression) <= 0 ) {
3405 1         19 $self->logger_error( '%s: empty string treated as zero',
3406             $self->impl_quote('eval') );
3407 1         3 $expression = 0;
3408             }
3409             #
3410             # Eval
3411             #
3412 169         398 my $rc = '';
3413             #
3414             # For $r->value() optimisations: outside of the try {} block
3415             # otherwise state optimisation seems to be off
3416             #
3417 169         385 state $registrations = undef;
3418             try {
3419 169     169   11829 local $MarpaX::Languages::M4::Impl::Default::INTEGER_BITS
3420             = $self->_integer_bits;
3421 169         2911 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         1498 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         58987 $r->read(\$expression);
3434 168         40209 my $ambiguous_status = $r->ambiguous;
3435 168 50       13313 if ($ambiguous_status) {
3436 0         0 Marpa::R2::exception( "Eval is ambiguous (ambiguous status is" . $ambiguous_status . "): $expression\n");
3437             }
3438              
3439 168 100       555 if (defined($registrations)) {
3440 167         1006 $r->registrations($registrations);
3441             }
3442 168         844 my $valuep = $r->value;
3443 162 100       6875 if (! defined($registrations)) {
3444 1         7 $registrations = $r->registrations();
3445             }
3446 162 50       662 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         373 ->bitvector_to_base( $radix, ${$valuep}, $width );
  162         5132  
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   3904 $_ =~ s/^User bailed.*?\n//;
3460 7         195 $self->logger_error( '%s: %s', $self->impl_quote('eval'), "$_" );
3461 7         46 return;
3462 169         2267 };
3463              
3464 169         12427 return $rc;
3465             }
3466              
3467 1 50   1   5736 method _syscmd (Str $macroName, Bool $appendValue, Undef|Str $command?, Str @ignored --> Str) {
  1 50   8   2  
  1 50       169  
  1 50       10  
  1 50       2  
  1 50       124  
  1 50       5  
  1 50       3  
  1 50       103  
  1 50       6  
  1 50       2  
  1 50       109  
  1 0       7  
  1         2  
  1         575  
  1         1895  
  8         297  
  8         46  
  8         47  
  8         41  
  8         17  
  8         46  
  8         40  
  8         40  
  8         21  
  8         41  
  8         36  
  8         41  
  8         17  
  8         41  
  8         42  
  8         34  
  0         0  
  0         0  
  8         20  
3468 8 50       36 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         263 $self->_checkIgnored( $macroName, @ignored );
3476              
3477 8   50     36 $command //= '';
3478 8 50       56 if ( length($command) > 0 ) {
3479 8         20 my ( $stdout, $stderr, $success, $exitCode );
3480 8         35 my $executed = false;
3481             try {
3482 8     8   780 ( $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   185587 if ( !$@ ) {
3492 8         151 $executed = true;
3493             }
3494 8         158 };
3495 8 50       843 if ($executed) {
3496 8         921 $self->_lastSysExitCode( $exitCode >> 8 );
3497 8 50       1147 if ( $self->_cmdtounix ) {
3498 8         192 $stderr =~ s/\R/\n/g;
3499 8         52 $stdout =~ s/\R/\n/g;
3500             }
3501 8 50       92 if ( length($stderr) > 0 ) {
3502 0         0 $self->logger_error( '%s', $stderr );
3503             }
3504 8 100       80 if ($appendValue) {
3505 4         156 $self->impl_appendValue($stdout);
3506 4         152 return '';
3507             }
3508             else {
3509 4         181 return $stdout;
3510             }
3511             }
3512             }
3513 0         0 return '';
3514             }
3515              
3516 1 50   1   4065 method builtin_syscmd (Undef|Str $command?, Str @ignored --> Str) {
  1 50   4   3  
  1 50       156  
  1 50       7  
  1 50       3  
  1 0       119  
  1         6  
  1         2  
  1         106  
  1         1840  
  4         316  
  4         21  
  4         23  
  4         10  
  4         27  
  4         24  
  4         13  
  0         0  
  0         0  
  4         10  
3517 4         18 return $self->_syscmd( 'syscmd', true, $command, @ignored );
3518             }
3519              
3520 1 50   1   4051 method builtin_esyscmd (Undef|Str $command?, Str @ignored --> Str) {
  1 50   4   3  
  1 50       157  
  1 50       7  
  1 50       2  
  1 0       115  
  1         6  
  1         2  
  1         115  
  1         1852  
  4         433  
  4         26  
  4         24  
  4         14  
  4         44  
  4         31  
  4         17  
  0         0  
  0         0  
  4         15  
3521 4         27 return $self->_syscmd( 'esyscmd', false, $command, @ignored );
3522             }
3523              
3524 1 50   1   2304 method builtin_sysval (Str @ignored --> Str) {
  1 50   7   2  
  1 0       140  
  1         6  
  1         2  
  1         99  
  1         1871  
  7         735  
  7         44  
  7         41  
  0         0  
  0         0  
  7         23  
3525 7         249 $self->_checkIgnored( 'sysval', @ignored );
3526              
3527 7         167 return $self->_lastSysExitCode;
3528             }
3529              
3530 1 50   1   4706 method _mkstemp (Str $macro, Undef|Str $template?, Str @ignored --> Str) {
  1 50   2   2  
  1 50       162  
  1 50       6  
  1 50       3  
  1 50       114  
  1 50       6  
  1 50       2  
  1 50       109  
  1 0       6  
  1         2  
  1         338  
  1         1900  
  2         49  
  2         19  
  2         18  
  2         18  
  2         9  
  2         16  
  2         15  
  2         18  
  2         8  
  2         25  
  2         13  
  2         13  
  0         0  
  0         0  
  2         7  
3531 2 50       16 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         106 $self->_checkIgnored( $macro, @ignored );
3539              
3540 2   50     17 $template //= '';
3541 2         26 while ( !( $template =~ /XXXXXX$/ ) ) {
3542 6         40 $template .= 'X';
3543             }
3544 2         10 my $tmp = '';
3545             try {
3546 2     2   188 $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         38 };
3552              
3553 2         1308 return $self->impl_quote( $tmp->filename );
3554             }
3555              
3556 1 50   1   2492 method builtin_mkstemp (Str @args --> Str) {
  1 50   1   2  
  1 50       144  
  1         6  
  1         3  
  1         96  
  1         1834  
  1         104  
  1         9  
  1         3  
  1         2  
  1         11  
  1         8  
3557 1         31 return $self->_mkstemp( 'mkstemp', @args );
3558             }
3559              
3560 1 50   1   2378 method builtin_maketemp (Str @args --> Str) {
  1 50   1   2  
  1 50       134  
  1         6  
  1         2  
  1         93  
  1         1863  
  1         129  
  1         14  
  1         10  
  1         6  
  1         14  
  1         6  
3561 1         51 return $self->_mkstemp( 'maketemp', @args );
3562             }
3563              
3564 1 50   1   2254 method builtin_errprint (Str @args --> Str) {
  1 50   5   2  
  1 50       128  
  1         6  
  1         3  
  1         133  
  1         1838  
  5         380  
  5         50  
  5         24  
  6         12  
  6         27  
  5         11  
3565             #
3566             # debugfile is IGNORED
3567             #
3568 5         107 my $oldDebugfile = $self->_debugfile;
3569              
3570 5         165 $self->_set__debugfile(undef);
3571 5         244 $self->logger_error( '%s', join( ' ', @args ) );
3572 5         137 $self->_set__debugfile($oldDebugfile);
3573              
3574 5         204 return '';
3575             }
3576              
3577 1 50   1   2250 method builtin___file__ (Str @ignored --> Str) {
  1 50   2   3  
  1 0       128  
  1         6  
  1         2  
  1         94  
  1         1865  
  2         146  
  2         11  
  2         8  
  0         0  
  0         0  
  2         8  
3578 2         36 $self->_checkIgnored( '__file__', @ignored );
3579 2         41 return $self->__file__;
3580             }
3581              
3582 1 50   1   2260 method builtin___line__ (Str @ignored --> Str) {
  1 50   2   3  
  1 0       129  
  1         6  
  1         2  
  1         144  
  1         1822  
  2         127  
  2         11  
  2         7  
  0         0  
  0         0  
  2         5  
3583 2         34 $self->_checkIgnored( '__line__', @ignored );
3584 2         37 return $self->__line__;
3585             }
3586              
3587 1 50   1   2273 method builtin___program__ (Str @ignored --> Str) {
  1 50   2   3  
  1 0       125  
  1         7  
  1         7  
  1         108  
  1         1828  
  2         151  
  2         15  
  2         10  
  0         0  
  0         0  
  2         6  
3588 2         40 $self->_checkIgnored( '__program__', @ignored );
3589 2         44 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   3290 method _expansion2CodeRef (Str $name, Str $expansion --> CodeRef) {
  1 50   370   3  
  1 50       148  
  1 50       5  
  1 50       2  
  1 50       130  
  1 50       5  
  1 50       2  
  1         829  
  1         1775  
  370         4677  
  370         1465  
  370         1481  
  370         1268  
  370         700  
  370         1259  
  370         1368  
  370         1174  
  370         680  
  370         1540  
  370         830  
3600             #
3601             # Check macro content
3602             #
3603 370 100       7037 if ( $self->_warn_macro_sequence ) {
3604 2         353 my $r = $self->_warn_macro_sequence_regexp;
3605 2         81 my $offset = 0;
3606 2         6 my $len = length($expansion);
3607 2         34 while ( $offset
3608             = $r->regexp_exec( $self, $expansion, $offset ) >= 0 )
3609             {
3610             #
3611             # Skip empty matches
3612             #
3613 2 50       59 if ( $r->regexp_lpos_get(0) == $r->regexp_rpos_get(0) ) {
3614 0         0 $offset++;
3615             }
3616             else {
3617 2         235 $offset = $r->regexp_rpos_get(0);
3618 2         106 $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         6076 my $maxArgumentIndice = -1;
3640 368         877 my %wantedArgumentIndice = ();
3641 368         1403 my $newExpansion = quotemeta($expansion);
3642             #
3643             # Arguments and $0
3644             #
3645 368         1699 $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         477 my $dollarOne = substr($newExpansion, $-[1], $+[1] - $-[1]);
  276         1701  
3651 276 100       985 if ($dollarOne > $maxArgumentIndice) {
3652 124         278 $maxArgumentIndice = $dollarOne;
3653             }
3654 276 100       709 if ($dollarOne == 0) {
3655             # "\$0";
3656 40         268 "\" . \"" . quotemeta($name) . "\" . \"";
3657             } else {
3658 236         711 $wantedArgumentIndice{$dollarOne}++;
3659 236         1173 "\" . " . "\$_\[$dollarOne\]" . " . \"";
3660             }
3661             }/eg;
3662 368         1020 my $prepareArguments = "\n";
3663             #
3664             # We use unused argument indices from now on.
3665             #
3666             # Number of arguments.
3667             #
3668 368 100       1475 if ( $newExpansion =~ s/\\\$\\\#/" . \$nbArgs . "/g ) {
3669 25         92 $prepareArguments
3670             .= "\tmy \$nbArgs = \$#_; # \$_[0] is \$self\n";
3671             }
3672             #
3673             # Arguments expansion, unquoted.
3674             #
3675 368 100       1348 if ( $newExpansion =~ s/\\\$\\\*/" . \$listArgs . "/g ) {
3676 15         57 $prepareArguments
3677             .= "\tmy \$listArgs = join(',', map {\$_[\$_] // ''} (1..\$#_));\n";
3678             }
3679             #
3680             # Arguments expansion, quoted.
3681             #
3682 368 100       1440 if ( $newExpansion =~ s/\\\$\\\@/" . \$listArgsQuoted . "/g ) {
3683 46         135 $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       1499 if (%wantedArgumentIndice) {
3693 78         244 $prepareArguments .= "\n";
3694 78         629 foreach ( sort { $a <=> $b } keys %wantedArgumentIndice ) {
  62         283  
3695 132         353 $prepareArguments .= "\t\$_[$_] //= '';\n";
3696             }
3697             }
3698 368         1009 my $stub;
3699             my $error;
3700             #
3701             # If it fails, our fault
3702             #
3703 368         1552 my $stubSource = <<"STUB";
3704             sub {
3705             $prepareArguments
3706             \treturn "$newExpansion";
3707             }
3708             STUB
3709 368         82282 my $codeRef = eval "$stubSource";
3710 368 50       2406 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         7353 return $codeRef;
3718             }
3719              
3720 1 0   1   1912 method _issue_expect_message (Str $expected) {
  1 0   0   2  
  1 0       143  
  1 0       6  
  1 0       2  
  1         151  
  1         2360  
  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   1398 method impl_freezeState (--> Bool) {
  1 50   142   2  
  1         298  
  1         227  
  142         1734  
  142         432  
  142         226  
3733 142 100       1015 if ( !$self->_stateFreezed ) {
3734 140 50       2598 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   7 no strict 'vars';
  1         2  
  1         636  
  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         1651 $self->_set__stateFreezed(true);
3836             }
3837 142         7320 return true;
3838             }
3839              
3840 1 0   1   1408 method impl_reloadState (--> Bool) {
  1 0   0   3  
  1         1503  
  1         2125  
  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   6630 method impl_parseIncrementalFile (Str $file, Bool $silent?, Bool $parse?, Ref['SCALAR'] $contentp? --> ConsumerOf[M4Impl]) {
  1 50   29   3  
  1 50       159  
  1 50       6  
  1 50       2  
  1 50       120  
  1 50       9  
  1 50       3  
  1 50       103  
  1 50       6  
  1 50       1  
  1 50       99  
  1 50       6  
  1 50       2  
  1 50       1508  
  1         2093  
  29         895  
  29         121  
  29         93  
  29         113  
  29         86  
  29         66  
  29         114  
  29         123  
  29         109  
  29         56  
  29         114  
  29         109  
  29         102  
  29         58  
  29         100  
  29         104  
  29         104  
  29         66  
  29         256  
  29         52  
4014 29   33     137 $silent //= false;
4015 29   33     87 $parse //= true;
4016              
4017             my $uni_file
4018 29 50       162 = $ENV{M4_ENCODE_LOCALE} ? decode( locale => $file ) : $file;
4019              
4020 29 50       125 if ( $uni_file ne '-' ) {
4021 29         65 my $fh;
4022             try {
4023             $fh = IO::File->new(
4024             $ENV{M4_ENCODE_LOCALE}
4025 29   50 29   1815 ? encode( locale_fs => $uni_file )
4026             : $uni_file,
4027             'r'
4028             )
4029             || die $!;
4030 29 50       4508 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         359 };
4040              
4041 29 50       666 if ( !Undef->check($fh) ) {
4042 29         1121 $self->_set__nbInputProcessed( $self->_nbInputProcessed + 1 );
4043              
4044 29         1873 $self->_set___file__( $self->impl_quote($file) );
4045 29         3454 $self->_set___line__(0);
4046              
4047 29 50       1647 if ( $self->_canDebug('i') ) {
4048 0         0 $self->logger_debug( 'input read from %s', $file );
4049             }
4050 29         3202 $self->_set__eof(true);
4051 29         1473 my $content;
4052             try {
4053 29     29   1337 $content = do { local $/; <$fh>; };
  29         161  
  29         978  
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         310 };
4061             try {
4062 29     29   1159 $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         721 };
4070 29 50       990 if ( !Undef->check($content) ) {
4071 29 50       1119 if ( $self->_inctounix ) {
4072 29         667 $content =~ s/\R/\n/g;
4073             }
4074             }
4075 29 50       123 if ( !Undef->check($contentp) ) {
4076 29         296 ${$contentp} = $content;
  29         89  
4077             }
4078 29 50       131 if ($parse) {
4079 0         0 $self->impl_parseIncremental($content);
4080             }
4081 29 50       903 if ( $self->_canDebug('i') ) {
4082 0         0 $self->logger_debug( '%s: input exhausted', $file );
4083             }
4084             try {
4085 29     29   1166 $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         3291 };
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         621 return $self;
4157             }
4158              
4159 1 50   1   2751 method impl_parseIncremental (Str $input --> ConsumerOf[M4Impl]) {
  1 50   164   2  
  1 50       145  
  1 50       7  
  1 50       2  
  1         200  
  1         3357  
  164         3085  
  164         657  
  164         772  
  164         651  
  164         401  
  164         918  
  164         375  
4160             try {
4161             #
4162             # This can throw an exception
4163             #
4164 164     164   14850 $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   7395 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         134 $self->_set__unparsed($input);
4183 3         204 return;
4184 164         2358 };
4185 164         20511 return $self;
4186             }
4187              
4188 1 50   1   2210 method impl_isImplException (Any $obj --> Bool) {
  1 50   3   2  
  1 50       148  
  1 50       6  
  1         2  
  1         206  
  1         3198  
  3         81  
  3         19  
  3         18  
  3         15  
  3         8  
  3         6  
  3         8  
4189 3         19 my $blessed = blessed($obj);
4190 3 50       11 if ( !$blessed ) {
4191 0         0 return false;
4192             }
4193 3   50     29 my $DOES = $obj->can('DOES') || 'isa';
4194 3 50       12 if ( !grep { $obj->$DOES($_) } (ImplException) ) {
  3         29  
4195 0         0 return false;
4196             }
4197 3         125 return true;
4198             }
4199              
4200 1 50   1   2627 method impl_appendValue (Str $result --> ConsumerOf[M4Impl]) {
  1 50   2904   2  
  1 50       157  
  1 50       7  
  1 50       6  
  1         88  
  1         2261  
  2904         184449  
  2904         8095  
  2904         8262  
  2904         7367  
  2904         4286  
  2904         8043  
  2904         5251  
4201 2904         47347 $self->_lastDiversion->print($result);
4202 2904         101013 return $self;
4203             }
4204              
4205 1 50   1   2174 method impl_parse (Str $input --> Str) {
  1 50   140   3  
  1 50       152  
  1 50       7  
  1 50       2  
  1         137  
  1         3149  
  140         1827  
  140         596  
  140         654  
  140         538  
  140         302  
  140         641  
  140         357  
4206 140 50       1057 if ( $self->_eoi ) {
4207 0         0 $self->logger_error('No more input is accepted');
4208 0         0 return '';
4209             }
4210 140         892 $self->_set__eof(true);
4211 140         9975 return $self->impl_parseIncremental($input)->impl_value;
4212             }
4213              
4214 1 50   1   1759 method impl_setEoi (--> ConsumerOf[M4Impl]) {
  1 50   142   2  
  1         148  
  1         1700  
  142         1895  
  142         534  
  142         443  
4215 142         462 $self->_set__eoi(true);
4216 142         2722 $self->impl_freezeState;
4217 142         571 return $self;
4218             }
4219              
4220 1 50   1   1857 method impl_valueRef (--> Ref['SCALAR']) {
  1 50   140   2  
  1         149  
  1         2906  
  140         1765  
  140         523  
  140         245  
4221             #
4222             # If not already done, say input is over
4223             #
4224 140         2464 $self->impl_setEoi;
4225             #
4226             # Something left over ?
4227             #
4228 140 100       731 if ( $self->_unparsed ) {
4229 3         53 $self->impl_parseIncremental('');
4230             }
4231             #
4232             # Return a reference to the value
4233             #
4234 140         2931 return $self->_diversions_get(0)->sref;
4235             }
4236              
4237 1 50   1   1321 method impl_value (--> Str) {
  1 50   140   3  
  1         174  
  1         3094  
  140         11256  
  140         581  
  140         363  
4238 140         340 return ${ $self->impl_valueRef };
  140         2962  
4239             }
4240              
4241 1 0   1   1402 method impl_file (--> Str) {
  1 0   0   3  
  1         98  
  1         1799  
  0         0  
  0         0  
  0         0  
4242 0         0 return $self->__file__;
4243             }
4244              
4245 1 0   1   1343 method impl_program (--> Str) {
  1 0   0   2  
  1         96  
  1         1763  
  0         0  
  0         0  
  0         0  
4246 0         0 return $self->__program__;
4247             }
4248              
4249 1 0   1   1346 method impl_debugfile (--> Str) {
  1 0   0   3  
  1         123  
  1         1672  
  0         0  
  0         0  
  0         0  
4250 0         0 return $self->debugfile;
4251             }
4252              
4253 1 0   1   2213 method impl_canLog (Str $what --> Bool) {
  1 0   0   2  
  1 0       154  
  1 0       6  
  1 0       3  
  1         80  
  1         1842  
  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   1305 method impl_line (--> PositiveOrZeroInt) {
  1 0   0   2  
  1         97  
  1         2233  
  0         0  
  0         0  
  0         0  
4258 0         0 return $self->__line__;
4259             }
4260              
4261 1 0   1   1343 method impl_rc (--> Int) {
  1 0   0   2  
  1         93  
  1         2279  
  0         0  
  0         0  
  0         0  
4262 0         0 return $self->_rc;
4263             }
4264              
4265 1 0 0 1   3993 method _printable (Str|M4Macro $input, Bool $noQuote? --> Str) {
  1 0   0   3  
  1 0       167  
  1 0       6  
  1 0       2  
  1 0       177  
  1 0       6  
  1 0       2  
  1 0       159  
  1         1897  
  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   3552 method impl_macroExecute (ConsumerOf[M4Macro] $macro, @args --> Str|M4Macro) {
  1 50   11   2  
  1 50       162  
  1 50       6  
  1 50       2  
  1 50       278  
  1 100       1875  
  11         1649  
  11         52  
  11         57  
  11         49  
  11         29  
  11         25  
  11         77  
  11         81  
  11         55  
  11         349  
  11         27  
4278             #
4279             # m4wrap is not traced
4280             # include is not traced
4281             # sinclude is not traced
4282             #
4283 11 100 66     251 if ( $macro->stub == \&builtin_m4wrap
      66        
4284             || $macro->stub == \&builtin_include
4285             || $macro->stub == \&builtin_sinclude )
4286             {
4287 2         68 return $macro->macro_execute( $self, @args );
4288             }
4289             else {
4290 9         674 my $canTrace = $self->_canTrace($macro);
4291 9         480 return $self->impl_macroExecuteNoHeader( $macro,
4292             $self->impl_macroExecuteHeader( $macro, $canTrace ),
4293             $canTrace, @args );
4294             }
4295             }
4296              
4297 1 50 33 1   3494 method impl_macroExecuteHeader (ConsumerOf[M4Macro] $macro, Bool $canTrace --> PositiveOrZeroInt) {
  1 50   2450   3  
  1 50       154  
  1 50       6  
  1 50       2  
  1 50       180  
  1 50       6  
  1 50       2  
  1 50       179  
  1         6720  
  2450         28114  
  2450         7616  
  2450         8619  
  2450         8006  
  2450         5141  
  2450         4414  
  2450         11799  
  2450         13128  
  2450         9257  
  2450         55563  
  2450         8933  
  2450         5487  
  2450         8876  
  2450         4145  
4298 2450         6076 local $MarpaX::Languages::M4::MACRO = $macro;
4299 2450         58013 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       120245 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         39816 return $MarpaX::Languages::M4::MACROCALLID;
4312             }
4313              
4314 1 50 33 1   5315 method impl_macroExecuteNoHeader (ConsumerOf[M4Macro] $macro, PositiveOrZeroInt $macroCallId, Bool $canTrace, @args --> Str|M4Macro) {
  1 50   2449   3  
  1 50       156  
  1 50       6  
  1 50       2  
  1 50       175  
  1 50       7  
  1 50       2  
  1 50       104  
  1 50       6  
  1 50       2  
  1 50       489  
  1 100       2648  
  2449         33685  
  2449         7897  
  2449         10705  
  2449         9777  
  2449         4775  
  2449         4258  
  2449         12435  
  2449         12655  
  2449         9305  
  2449         56701  
  2449         8738  
  2449         4369  
  2449         8482  
  2449         7530  
  2449         7357  
  2449         4226  
  2449         8753  
  2449         12019  
  2449         4917  
4315             #
4316             # Execute the macro
4317             #
4318 2449         4996 local $MarpaX::Languages::M4::MACRO = $macro;
4319 2449         5210 local $MarpaX::Languages::M4::MACROCALLID = $macroCallId;
4320 2449         4338 my $printableMacroName;
4321              
4322 2449 0 0     7411 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         52902 my $rc = $macro->macro_execute( $self, @args );
4338              
4339 2447 0 0     33592 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         42006 return $rc;
4362             }
4363              
4364 1 0   1   1384 method impl_macroCallId (--> PositiveOrZeroInt) {
  1 0   0   3  
  1         99  
  1         6786  
  0         0  
  0         0  
  0         0  
4365 0         0 return $self->_macroCallId;
4366             }
4367              
4368 1 0   1   1350 method impl_unparsed (--> Str) {
  1 0   0   2  
  1         100  
  1         2428  
  0         0  
  0         0  
  0         0  
4369 0         0 return $self->_unparsed;
4370             }
4371              
4372 1 50   1   1347 method impl_eoi (--> Bool) {
  1 50   1   2  
  1         98  
  1         1844  
  1         13  
  1         5  
  1         2  
4373 1         18 return $self->_eoi;
4374             }
4375              
4376 1 50   1   2296 method impl_raiseException (Str $message --> Undef) {
  1 50   7   2  
  1 50       158  
  1 50       6  
  1 50       2  
  1         112  
  1         2117  
  7         86  
  7         33  
  7         33  
  7         31  
  7         15  
  7         33  
  7         18  
4377 7         151 $self->logger_error($message);
4378 7         49 ImplException->throw($message);
4379             }
4380              
4381 1         2092 has _nbInputProcessed => (
4382             is => 'rwp',
4383             isa => PositiveOrZeroInt,
4384             handles_via => 'Number',
4385             default => 0
4386             );
4387              
4388 1 0   1   1519 method impl_nbInputProcessed (--> PositiveOrZeroInt) {
  1 0   0   6  
  1         107  
  1         1529  
  0            
  0            
  0            
4389 0           return $self->_nbInputProcessed;
4390             }
4391              
4392 1 0   1   1909 method impl_readFromStdin (--> ConsumerOf[M4Impl]) {
  1 0   0   2  
  1         114  
  1         2348  
  0            
  0            
  0            
4393 0           $self->interactive(true);
4394 0           return $self;
4395             }
4396              
4397 1 0   1   2057 method impl_debugFile (--> Undef|Str) {
  1 0   0   2  
  1         116  
  1         3049  
  0            
  0            
  0            
4398 0           return $self->_debugfile;
4399             }
4400              
4401 1 0   1   1423 method impl_nestingLimit (--> PositiveOrZeroInt) {
  1 0   0   2  
  1         154  
  1         3366  
  0            
  0            
  0            
4402 0           return $self->_nesting_limit;
4403             }
4404              
4405 1         2113 with 'MarpaX::Languages::M4::Role::Impl';
4406 1         2933 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.020
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