File Coverage

blib/lib/LaTeX/Replicase.pm
Criterion Covered Total %
statement 459 495 92.7
branch 300 368 81.5
condition 158 229 69.0
subroutine 21 21 100.0
pod 2 2 100.0
total 940 1115 84.3


line stmt bran cond sub pod time code
1             package LaTeX::Replicase;
2              
3 2     2   290838 use 5.010;
  2         8  
4 2     2   10 use strict;
  2         12  
  2         65  
5 2     2   9 use warnings;
  2         3  
  2         99  
6 2     2   12 use utf8;
  2         6  
  2         10  
7              
8 2     2   158 use File::Basename qw(fileparse);
  2         3  
  2         226  
9 2     2   12 use File::Path qw(make_path);
  2         3  
  2         135  
10 2     2   16874 use File::Compare;
  2         2350  
  2         190  
11 2     2   15 use Carp;
  2         3  
  2         19097  
12              
13             require Exporter;
14              
15             our @ISA = qw(Exporter);
16              
17             our %EXPORT_TAGS = ('all' => [ qw(
18             replication
19             tex_escape
20             ) ],
21             );
22              
23             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
24             our @EXPORT = qw( );
25              
26             our $VERSION = '0.599';
27             our $DEBUG; $DEBUG = 0 unless defined $DEBUG;
28             our @logs;
29             our $nlo = 1; # Number Line Output, start of 1
30              
31             sub tex_escape {
32 15 100 66 15 1 336375 return if ! $_[0] or $_[0] =~/^[a-zA-Z0-9,=:;!\.\s\+\-\*]+$/ or $_[0] =~s/^%%%://;
      100        
33              
34 11         30 for( $_[0] ) {
35 11         29 s/\\/\\textbackslash\{\}/g;
36 11         82 s/([%}{_&\$\#])/\\$1/g; # masking active symbols
37 11         61 s/\^/\\$&\{\}/g; # ^ --> \^{}
38              
39 11 100 66     61 s/~/\\texttt\{\\~\{\}\}/g if $_[1] && $_[1] =~/~/; # tilde (~) --> \texttt{\~{}}
40             }
41             }
42              
43              
44             sub replication {
45 21     21 1 241860 my( $source, $info, %op ) = @_;
46              
47 21 100       48 our $DEBUG; $DEBUG = $op{debug} if defined $op{debug};
  21         120  
48 21         56 $DEBUG += 0;
49 21         74 our @logs = ();
50              
51 21 100 66     136 if( defined( $source ) && length( $source ) ) {
52              
53 20 100       109 if(ref \$source eq 'SCALAR') {
    100          
54 17         45 for( $source ) {
55 17         88 s/^\s+//;
56 17         50 s/\s+.*//s;
57              
58 17 50       868 $_ = (glob)[0] if $^O =~/(?:linux|bsd|darwin|solaris|sunos)/;
59             }
60             }
61             elsif(ref $source ne 'ARRAY') {
62 1         4 $_ = "!!! ERROR#6: invalid FILE or ARRAY input!";
63 1 50       5 $op{silent} or carp $_;
64              
65 1         3 push @logs, $_;
66 1         6 return \@logs;
67             }
68              
69             }
70             else {
71 1         5 $_ = "!!! ERROR#0: undefined input FILE or ARRAY!";
72 1 50       5 $op{silent} or carp $_;
73              
74 1         4 push @logs, $_;
75 1         5 return \@logs;
76             }
77              
78 19 100       122 push @logs, "--> Checking source data: '$source'" if $DEBUG;
79              
80 19 100 100     382 if((ref \$source eq 'SCALAR' and ! -s $source) or (ref $source eq 'ARRAY' and ! @$source)) {
      66        
      66        
81 1         4 $_ = "!!! ERROR#1: source ('$source') does NOT exist or is EMPTY!";
82 1 50       33 $op{silent} or carp $_;
83              
84 1         4 push @logs, $_;
85 1         5 return \@logs;
86             }
87              
88             # global data of TeX file
89 18 100 100     171 unless( $info
      66        
90             and (( ref $info eq 'HASH' and %$info ) or (ref $info eq 'ARRAY' and @$info ))
91             ) {
92 2         6 $_= "!!! ERROR#2: EMPTY or WRONG data!";
93 2 50       8 $op{silent} or carp $_;
94              
95 2         6 push @logs, $_;
96 2         12 return \@logs;
97             }
98              
99             # environments: global for %%%V:, %%%VAR: ; and local for %%%VAR:
100 16         45 my $data = my $vardata = $info;
101              
102 16         38 my( $filename, $dir );
103 16 100       49 if( ref \$source eq 'SCALAR') {
104 14         547 ( $filename, $dir, my($ext)) = fileparse( $source );
105             }
106             else { # for ARRAY input
107 2         7 $filename = 'ready.tex';
108 2         5 $dir = '.';
109             }
110              
111 16         51 my( $fh, $ofile );
112 16 100 66     100 if( defined( $_ = $op{ofile} ) && length ) {
113 15 100       60 if(/::STDOUT$/) {
114 1         4 $fh = $ofile = $_;
115             }
116             else {
117 14         50 s/^\s+//;
118 14         39 s/\s+.*//s;
119 14 50       550 $ofile = ( $^O =~/(?:linux|bsd|darwin|solaris|sunos)/ ) ? (glob)[0] : $_;
120             }
121             }
122             else {
123 1   33     6 my $outdir = $op{outdir} // "$dir/$$"; # Target dir for ready TeX file
124 1 50       4 if( length $outdir ) {
125 1         4 for( $outdir ) {
126 1         3 s/^\s+//;
127 1         5 s/\s+.*//s;
128              
129 1 50       54 $_ = (glob)[0] if $^O =~/(?:linux|bsd|darwin|solaris|sunos)/;
130             }
131             }
132             else { # for $outdir = ''
133 0         0 $outdir = "./$$";
134             }
135              
136 1 50       40 unless( -d $outdir ) {
137 1         285 make_path( $outdir, {error => \my $err} );
138              
139 1 50 33     13 if ($err && @$err) {
140              
141 0         0 for my $diag (@$err) {
142 0         0 my( $path, $message ) = %$diag;
143 0 0 0     0 $_ = ( $path && length( $path ) ) ?
144             "!!! ERROR#7: ('$path' creation problem) $message" :
145             "!!! ERROR#8: (general error) $message";
146 0 0       0 $op{silent} or carp $_;
147 0         0 push @logs, $_;
148             }
149              
150 0         0 return \@logs;
151             }
152              
153             }
154              
155 1         4 $ofile = "$outdir/$filename";
156             }
157              
158 16 100       79 push @logs, "--> Using '$ofile' file as output" if $DEBUG;
159              
160             # new file must be different
161 16 100 66     330 if( -s $ofile and ref \$source eq 'SCALAR'
      66        
      66        
162             and (
163             ( $source eq $ofile and compare( $source, $ofile ) == 0 )
164             or
165             ( join(',', stat $source) eq join(',', stat $ofile) )
166             )
167             ) {
168 1         195 $_= "!!! ERROR#3: Input (template) & output files match. Can't overwrite template file!";
169 1 50       6 $op{silent} or carp $_;
170              
171 1         4 push @logs, $_;
172 1         6 return \@logs;
173             }
174              
175 15         46 my $TEMPLATE;
176 15 100       63 if( ref \$source eq 'SCALAR') {
177 13 100       52 my $mode = $op{utf8} ? ':utf8' : '';
178              
179 13 100       43 push @logs, "--> Open '$source'" if $DEBUG;
180              
181 13 50       668 open $TEMPLATE, "<:raw$mode", $source or do{
182 0         0 $_= "!!! ERROR#4: $!";
183 0 0       0 $op{silent} or carp $_;
184              
185 0         0 push @logs, $_;
186 0         0 return \@logs;
187             };
188             }
189              
190 15 100       140 unless( $fh ) { # it's not "::STDOUT"
191 14 100       61 my $mode = $op{utf8} ? ':encoding(utf8)' : '';
192              
193 14 100       65 push @logs, "--> Open '$ofile'" if $DEBUG;
194              
195 1 50   1   993 open $fh, ">$mode", $ofile or do{
  1         19  
  1         6  
  14         1660  
196 0         0 $_= "!!! ERROR#5: $!";
197 0 0       0 $op{silent} or carp $_;
198              
199 0         0 push @logs, $_;
200 0         0 return \@logs;
201             };
202             }
203              
204 15         1483 $nlo = 1;
205 15         36 my $chkVAR = 0; # check %%%VAR for ARRAY|HASH|SCALAR|REF->SCALAR type
206 15         66 my $key;
207             my $tdz; # flag of The Dead Zone
208 15         0 my @columns;
209              
210             =for comment
211             =begin comment
212             @columns:
213             [...]: -- table columns
214             [...]{...} -- descriptions (properties) of table columns:
215             {ki} -- name (key || index ) of a variable from $data->{ $key }
216             {%} -- NO \par
217             {p} -- to paste text on right
218             {head}[...] -- TeX strings before %%%V:
219             {tail}[...] -- TeX strings after %%%V:
220             {eX}[...] -- indices of {head} that eXcept for the first and last elements and rows of %%%VAR:
221             =end comment
222             =cut
223              
224 15 100       45 if( $TEMPLATE ) {
225 13         345 while( my $z = <$TEMPLATE> ) {
226              
227 870 100       2465 if( &_line_decryption( $fh, $info, \$z, \$data, \$vardata, \$chkVAR, \$key, \$tdz, \@columns, \%op ) ) {
228 10         21 print { $fh } <$TEMPLATE>;
  10         182  
229 10         48 last; #--> Exit template
230             }
231 860         3295 undef $z;
232              
233             }
234 13         198 close $TEMPLATE;
235             }
236             else {
237 2         5 my $e;
238 2         7 for my $z ( @$source ) {
239              
240 228 100       530 if( $e ) {
241 6         11 print { $fh } $z;
  6         55  
242             }
243             else {
244 222         600 $e = &_line_decryption( $fh, $info, \$z, \$data, \$vardata, \$chkVAR, \$key, \$tdz, \@columns, \%op );
245             }
246             }
247             }
248              
249 15 50       50 if( defined $key ) {
250 0         0 &_var_output( $fh, $key, $vardata, \@columns, \%op );
251              
252 0         0 $_ = "~~> l.$. WARNING#1: Missing '%%%ENDx' tag for '$key'";
253 0 0       0 $op{silent} or carp $_;
254 0         0 push @logs, $_;
255             }
256              
257 15 100       1471 $ofile =~/::STDOUT$/ or close $fh;
258              
259 15 100       192 @logs or return;
260 6         70 return \@logs;
261             }
262              
263             #---------------------
264             # Internal function(s)
265              
266             sub _line_decryption {
267 1092     1092   3016 my( $fh, $info, $z, $data, $vardata, $chkVAR, $key, $tdz, $columns, $op ) = @_;
268              
269 1092         1840 our $DEBUG;
270 1092         1830 our @logs;
271 1092         1798 our $nlo;
272              
273 1092 100       3453 if( defined $$key ) { # We are in VAR-structure
    100          
274              
275 471 100       2290 return unless $$z =~/%%%[AETV]\S*:/; # Nope control tags --> drop TeX line
276              
277 357 100 66     2845 if( $$z =~/%%%(?:END(?[TZ]?)|TDZ|VAR):/) {
    50 100        
      0        
      33        
      66        
278 70         616 my $t = $+{t};
279 70         316 &_var_output( $fh, $$key, $$vardata, $columns, $op );
280              
281             # Clear the VAR-structure for the next external VARiable
282 70         165 $$chkVAR = 0;
283 70         157 undef $$key;
284 70         404 @$columns = ();
285              
286 70 100 100     313 return 1 if $t && $t eq 'T'; # end of template area --> Exit template
287              
288 64 100 66     187 undef $$tdz if $t && $t eq 'Z';
289              
290 64 100       547 return if $$z =~/%%%ENDZ?:/; # end of %%%VAR: tag
291              
292 10 100       72 if( $$z =~/%%%+TDZ:/) { # The Dead Zone
293 7         18 $$tdz = 1;
294 7         29 return;
295             }
296              
297             }
298             elsif( (ref $$vardata eq 'HASH' and (
299             ref $$vardata->{ $$key } eq 'HASH'
300             or ref $$vardata->{ $$key } eq 'ARRAY'
301             or ref \$$vardata->{ $$key } eq 'SCALAR'
302             or ref $$vardata->{ $$key } eq 'SCALAR' # REF->SCALAR
303             )
304             )
305             or (ref $$vardata eq 'ARRAY' and (
306             ref $$vardata->[ $$key ] eq 'HASH'
307             or ref $$vardata->[ $$key ] eq 'ARRAY'
308             or ref \$$vardata->[ $$key ] eq 'SCALAR'
309             or ref $$vardata->[ $$key ] eq 'SCALAR' # REF->SCALAR
310             )
311             )
312             ) {
313 287 100       822 my $vk = ref $$vardata eq 'HASH' ? $$vardata->{ $$key } : $$vardata->[ $$key ];
314 287 100 100     1089 my $sclr = (ref \$vk eq 'SCALAR' or ref $vk eq 'SCALAR') ? 1 : 0;
315              
316             # Index of column in target table
317 287 100 100     1284 my $j = ( @$columns && exists( $columns->[-1]{ki} ) ) ?
      50        
318             @$columns :
319             ($#$columns // 0);
320 287 100 100     1014 $j = 0 if $j < 0 or $sclr;
321              
322 287 100 100     4661 if( ! $sclr and $$z =~/%%%V:\s*([^\s:%#]+)(%?)\s?(.*)/) {
    100 100        
323             # this V-variable is nested in a VAR-structure
324 112         308 my $ki = $1; # name (key or index) of V-variable
325 112         235 my $Np = $2; # NO \par
326 112         267 my $paste = $3; # on right
327              
328 112 100 100     2086 if( $$chkVAR == 0b0001) { # V-variable is in {HASH|ARRAY}.ARRAY of VAR-structure
    100 66        
    100 33        
    100          
329              
330 32 100 66     309 if( $ki eq '@') {
    100 66        
    50          
331 1         3 $ki = '0-'; # ALL elements
332 1         5 $columns->[$j]{ki} = $ki; # starting index (unnamed meaning)
333             }
334             elsif( $ki =~/^\-*(\d+)$/ && ($1 < @$vk or ($ki < 0 && $1 == @$vk)) ) {
335             # specific indices, e.g.: 0 or 3 or -1
336 16         55 $columns->[$j]{ki} = $ki;
337             }
338             elsif( $ki =~/^[\d,\-]+$/) {
339             # mixed indexes, e.g.: 1-3,6-7-9,-,4,-5,0,7- or 3- (i.e. 3..arr_end) or 0-5 (0..5) or -1- (-1,-2,..arr_start)
340 15         39 for( $ki ) {
341 15         79 s/\-+/-/g;
342 15         54 s/,+/,/g;
343             }
344 15         52 $columns->[$j]{ki} = $ki;
345             }
346             else {
347 0 0 0     0 push @logs, "~~> l.$. WARNING#8: ARRAY index is not numeric in %%%V:". $ki if $DEBUG or ! $op->{ignore};
348             }
349              
350             }
351             elsif( $$chkVAR == 0b0010) { # V-variable is in {HASH|ARRAY}.HASH of VAR-structure
352              
353 35         81 for my $d ( @$vk ) {
354 35 50       110 if( exists $d->{$ki} ) {
355 35         95 $columns->[$j]{ki} = $ki; # save variable name in j-th column
356 35         150 last;
357             }
358             }
359             }
360             elsif( $$chkVAR == 0b0100 or $$chkVAR == 0b01000 ) { # V-variable is SCALAR (or REF->SCALAR) in regular ARRAY of VAR-structure
361              
362 15 100 33     101 if( $ki eq '@') {
    100 66        
    100          
363 5         13 $ki = '0-'; # ALL elements
364 5         17 $columns->[$j]{ki} = $ki; # starting index (unnamed meaning)
365             }
366             elsif( $ki =~/^\-*(\d+)$/ && ($1 < @$vk or ($ki < 0 && $1 == @$vk)) ) {
367             # specific indices, e.g.: 0 or 3 or -1
368 4         15 $columns->[$j]{ki} = $ki;
369             }
370             elsif( $ki =~/^[\d,\-]+$/) {
371             # mixed indexes, e.g.: 1-3,6-7-9,-,4,-5,0,7- or 3- (i.e. 3..arr_end) or 0-5 (0..5) or -1- (-1,-2,..arr_start)
372 5         14 for( $ki ) {
373 5         28 s/\-+/-/g;
374 5         24 s/,+/,/g;
375             }
376 5         15 $columns->[$j]{ki} = $ki;
377             }
378              
379             }
380             elsif( ref $vk eq 'HASH'
381             and ( (ref \$vk->{$ki} eq 'SCALAR' and defined( $vk->{$ki} ) )
382             or ( ref $vk->{$ki} eq 'SCALAR' and defined( ${ $vk->{$ki} } ) )
383             or ( $ki eq '@'
384             and exists($vk->{$ki})
385             and ref $vk->{$ki} eq 'ARRAY'
386             )
387             )
388             ) {
389 24         71 $columns->[$j]{ki} = $ki; # save variable key in j-th element
390             }
391              
392 112 100       434 &_set_column( $Np, $paste, $columns->[$j] ) if exists $columns->[$j]{ki};
393             }
394             elsif( $$z =~/(?.+?)\s?%%%+ADD(?[EX]?):(?

%?)/

395             or $$z =~/^\s*%%%+ADD(?[EX]?):(?

%?)\s?(?.*?)[\r\n]*$/

396             ) {
397 173         1129 my $s = $+{s};
398              
399 173 100       880 if( $+{p} ) {
400 45 100       128 length($s) or return;
401             }
402             else {
403 128         312 $s .= "\n";
404             }
405              
406 172 100       759 if( $+{t} eq 'E') { # %%%ADDE:
407 23 50 33     162 if( @$columns && exists( $columns->[-1]{ki} ) && (! $columns->[$j] or $sclr) ) {
      66        
      33        
408 23         42 push @{ $columns->[-1]{tail} }, $s;
  23         90  
409             }
410             else {
411 0         0 push @{ $columns->[$j]{head} }, $s;
  0         0  
412             }
413             }
414             else {
415 149         286 push @{ $columns->[$j]{head} }, $s;
  149         712  
416 149 100 100     1007 $columns->[$j]{eX}{ $#{ $columns->[$j]{head} } } = undef if ! $sclr and $+{t} eq 'X'; # $$chkVAR && ... %%%ADDX:
  33         176  
417             }
418             }
419              
420 286         1245 return;
421             }
422             else {
423 0         0 return;
424             }
425              
426             }
427             elsif( $$z =~/%%%+END(?[TZ]?):/) { # end of template area
428              
429             # Clear the VAR-structure for the next external variable
430 38         88 $$chkVAR = 0;
431 38         70 undef $$key;
432 38         78 @$columns = ();
433              
434 38 100       434 return 1 if $+{t} eq 'T'; # end of template area --> Exit template
435              
436 32 100       178 undef $$tdz if $+{t} eq 'Z'; # End of TDZ
437 32         123 return;
438             }
439              
440 586 100       1675 $$tdz = 1 if $$z =~s/^\s*%%%+TDZ:\s?[\r\n]*//; # The Dead Zone
441              
442 586 100       1349 if( $$tdz ) { # The Dead Zone is ON
443 124 100       304 if( length $$z ) {# Output TeX
444 116         244 print { $fh } $$z;
  116         345  
445 116         212 ++$nlo;
446             }
447 124         365 return;
448             }
449              
450 462 100       2322 if( $$z =~/(.*?)\s?%%%+VAR:\s*([^\s:%#]+)(%?)\s?(.*)/) {
    50          
    100          
451 86         264 my $before = $1;
452 86         199 my $k = $2; # name (key)
453 86         201 my $Np = $3; # NO \par
454 86         219 my $paste = $4; # on right text for SCALAR only
455              
456             # root or global structure (environment)
457 86 100       255 my $vd = ( $k =~s/^\/+//) ? $info : $$data;
458              
459 86         156 my $x; # for unknown/undefined sub-key
460              
461             # Search nested sub-keys
462 86         285 for my $sk ( split '/', $k ) {
463 87         197 $$vardata = $vd;
464 87 50       232 length( $sk ) or next;
465              
466 87 100 66     687 if( $sk =~/^\d+$/ && ref $vd eq 'ARRAY' and defined( $vd->[$sk] )) {
    100 66        
      66        
467 3 100       9 last if &_data_redef( $sk, $vd->[$sk], \$k, \$vd, \$x );
468             }
469             elsif( ref $vd eq 'HASH' and exists( $vd->{$sk} )) {
470 69 100       218 last if &_data_redef( $sk, $vd->{$sk}, \$k, \$vd, \$x );
471             }
472             else {
473 15         35 $x = $sk;
474 15         31 last;
475             }
476             }
477              
478             # Clear the VAR-structure for a new variable
479 86         191 $$chkVAR = 0;
480 86         174 undef $$key;
481 86         170 @$columns = ();
482              
483 86 100       206 if( $x ) {
484 15 100 100     101 push @logs, "~~> l.$. WARNING#2: unknown or undef ARRAY|HASH|SCALAR|REF.SCALAR of sub-key '$x' in %%%VAR:". $k if $DEBUG or ! $op->{ignore};
485              
486 15         31 $$vardata = $$data;
487 15         28 print { $fh } $$z;
  15         34  
488 15         27 ++$nlo;
489 15         52 return;
490             }
491              
492             # key or sub-...sub-key is found
493 71 100       209 push @logs, "--> l.$. Found %%%VAR:". $k if $DEBUG;
494              
495 71 50       225 my $vk = ref $$vardata eq 'HASH' ? $$vardata->{$k} :
    100          
496             (ref $$vardata eq 'ARRAY' ? $$vardata->[$k] : undef);
497              
498 71 50       213 unless( $vk ) {
499 0 0 0     0 push @logs, "~~> l.$. NOT defined key in %%%VAR:". $k if $DEBUG && $op->{def};
500 0         0 return;
501             }
502              
503 71 100       239 return if &_chk_var( $fh, $k, $vk, $Np, \$paste, \$before, $chkVAR, $columns, $z, $op );
504              
505             # push @logs, "--> l.$. Remember key = '$k' (chkVAR=$$chkVAR), type: ".ref($vk) if $DEBUG; ###AG
506              
507 70         159 $$key = $k; # save key name
508 70         249 return;
509              
510             }
511             elsif( $$z =~/%%%V:\s*=(def|esc|ignore|silent|debug)=\s*(\S*)/) { # setting up facultative options
512 0   0     0 $op->{$1} = $2 || 0;
513 0         0 return;
514             }
515             elsif( $$z =~/%%%V:\s*(?[^\s:%#]+)(?

%?)\s?(?.*)/) {

516 48         283 my $k = $+{k};
517              
518 48         126 my %el;
519 48         233 &_set_column( $+{p}, $+{s}, \%el );
520              
521 48         127 my $inidata = $$data; # save initial environment
522              
523 48 100       178 if( $k =~s/^\/+//) {
524 7         19 $$data = $info; # reset to root environment
525              
526 7 100       30 length($k) or return;
527             }
528              
529             # Search nested sub-keys
530 44         85 my $x = 0; # for unknown sub-key
531 44         133 for my $sk ( split '/', $k ) {
532 51 50       146 length( $sk ) or next;
533              
534 51         86 my $d;
535 51 100 100     411 if( $sk =~/^\d+$/ && ref $$data eq 'ARRAY' && defined( $$data->[$sk] )) {
    100 66        
      66        
536 6         15 $d = $$data->[$sk];
537             }
538             elsif( ref $$data eq 'HASH' && exists( $$data->{$sk} )) {
539 15         41 $d = $$data->{$sk};
540             }
541             else {
542 30 100 100     195 push @logs, "~~> l.$. WARNING#3: unknown sub-key '$sk' in %%%V:". $k if $DEBUG or ! $op->{ignore};
543              
544 30         58 print { $fh } $$z;
  30         64  
545 30         58 ++$nlo;
546              
547 30         58 $x = 1;
548 30         62 last;
549             }
550              
551             # Check type
552 21 100 100     158 if( (ref $d eq 'ARRAY' or ref $d eq 'HASH') ) {
553 9         20 $$data = $d; # sub-key (path) found: redefined
554 9         22 next;
555             }
556              
557 12         24 my $v;
558 12 100       46 if( ref \$d eq 'SCALAR') {
    100          
559 10         22 $v = $d;
560             }
561             elsif( ref $d eq 'SCALAR') { # REF->SCALAR
562 1         4 $v = $$d;
563             }
564             else {
565 1 50 33     15 push @logs, "~~> l.$. WARNING#4: wrong type (not SCALAR|ARRAY|HASH) of '$sk' in %%%V:". $k if $DEBUG or ! $op->{ignore};
566              
567 1         4 print { $fh } $$z;
  1         4  
568 1         3 ++$nlo;
569              
570 1         3 $x = 1;
571 1         4 last;
572             }
573              
574 11         52 &_v_print( $fh, $k, $v, \%el, $op );
575              
576 11         23 $x = 1;
577 11         27 last;
578             }
579              
580 44 100       125 $$data = $inidata if $x; # value found or unknown sub-key: reset to initial environment
581              
582 44         153 return;
583             }
584              
585 328         586 print { $fh } $$z;
  328         1416  
586 328         585 ++$nlo;
587              
588 328         1104 return;
589             }
590              
591              
592             sub _set_column {
593 179     179   652 my( $Np, $paste, $column ) = @_;
594              
595 179 100       525 $column->{'%'} = 1 if $Np;
596 179 100       537 $column->{p} = $paste if length $paste;
597             }
598              
599             sub _data_redef {
600 72     72   212 my( $sk, $d, $k, $data, $x ) = @_;
601              
602 72 100 100     274 if( ref $d eq 'ARRAY' or ref $d eq 'HASH') {
603 46         101 $$data = $d; # redefined for %%%VAR:
604 46         181 return 0;
605             }
606              
607 26 50 66     95 if( ref \$d eq 'SCALAR' or ref $d eq 'SCALAR') {
608 26         56 $$k = $sk;
609             }
610             else {
611 0         0 $$x = $sk;
612             }
613 26         93 return 1;
614             }
615              
616             sub _chk_var {
617 71     71   287 my( $fh, $k, $vk, $Np, $paste, $before, $chkVAR, $columns, $z, $op ) = @_;
618              
619 71         146 our $DEBUG;
620 71         138 our @logs;
621 71         121 our $nlo;
622              
623 71 100 100     263 if( ref $vk eq 'ARRAY') {
    100          
624              
625 36 100       63 if( @{ $vk } ) {
  36         96  
626             # Check ARRAY.{ARRAY|HASH|SCALAR[.REF]}
627              
628 35         85 for my $d ( @{ $vk } ) {
  35         96  
629 127 100       375 if(ref $d eq 'ARRAY'){
    100          
    100          
    50          
630 35         77 $$chkVAR |= 0b00001;
631             }
632             elsif(ref $d eq 'HASH') {
633 22         54 $$chkVAR |= 0b00010;
634             }
635             elsif(ref \$d eq 'SCALAR') {
636 66         141 $$chkVAR |= 0b00100;
637             }
638             elsif(ref $d eq 'SCALAR') { # REF->SCALAR
639 4         9 $$chkVAR |= 0b01000;
640             }
641             else {
642 0         0 $$chkVAR |= 0b10000;
643             }
644             }
645             }
646             else {
647 1         3 $$chkVAR |= 0b00100; # by default, SCALAR
648             }
649              
650 36 100 66     258 if( ! $$chkVAR or $$chkVAR > 0b01000 or ($$chkVAR & ($$chkVAR - 1)) ) {
      66        
651 1 50 33     13 push @logs, "~~> l.$. WARNING#6: mixed types (ARRAY with HASH with SCALAR or other) of %%%VAR:". $k if $DEBUG or ! $op->{ignore};
652              
653 1         3 print { $fh } $$z;
  1         4  
654 1         3 ++$nlo;
655 1         6 return 1;
656             }
657             }
658             elsif( ref \$vk eq 'SCALAR' or ref $vk eq 'SCALAR') {
659 26         96 $columns->[0]{ki} = $k;
660 26         94 &_set_column( $Np, $$paste, $columns->[0] );
661             }
662              
663 70 100       192 if( $$before ) {# Output prefix TeX
664 13         39 print { $fh } $$before;
  13         61  
665             # ++$nlo;
666             }
667              
668 70         225 return 0;
669             }
670              
671             # VALUE output
672             sub _v_print {
673 418     418   1186 my( $fh, $k, $v, $el, $op ) = @_;
674 418 100       1072 $v = $$v if ref $v eq 'SCALAR';
675              
676 418         714 our $DEBUG;
677 418         718 our @logs;
678 418         776 our $nlo;
679              
680 418 100       953 if( defined $v ) {
681 378 100       1017 tex_escape( $v, $op->{esc} ) if $op->{esc};
682              
683 378 100       960 push @logs, "--> l.$.>$nlo".' Insert %%%V[AR]:'. $k .'= '. $v if $DEBUG;
684              
685 378         679 print { $fh } $v;
  378         1756  
686 378 100       1199 print { $fh } $el->{p} if exists $el->{p};
  10         71  
687              
688 378         1235 ++$nlo while $v =~/\n/g;
689              
690 378 100       1113 return if $el->{'%'};
691              
692 252         467 print { $fh } "\n"; # NO:YES \par
  252         821  
693 252         630 ++$nlo;
694             }
695             else {
696 40 50 66     143 push @logs, "~~> l.$.".' NOT defined %%%V[AR]:'. $k if $DEBUG && $op->{def};
697             }
698              
699             }
700              
701             # HEAD-TAIL output
702             sub _ht_print {
703 814     814   2044 my( $fh, $el, $ht, $border ) = @_;
704              
705 814 100       2462 $el->{$ht} or return;
706              
707 401         752 our $DEBUG;
708 401         691 our @logs;
709 401         713 our $nlo;
710              
711 401         721 my $i = 0;
712 401         712 foreach( @{ $el->{$ht} } ) {
  401         1152  
713 490 100 100     1985 next if $ht eq 'head' and $border && exists( $el->{eX} ) && exists( $el->{eX}{$i} );
      100        
      100        
714              
715 457 100       1183 push @logs, "-->\tl.$.>$nlo Insert $ht: ". $_ if $DEBUG;
716              
717 457         838 print { $fh } $_;
  457         2801  
718 457         998 ++$nlo;
719             }
720             continue {
721 490         1274 ++$i;
722             }
723              
724             }
725              
726             # HEAD-VALUE-TAIL output
727             sub _hvt_print {
728 411     411   1148 my( $fh, $ki, $val, $el, $op, $border ) = @_;
729              
730 411         3246 our $DEBUG;
731 411         687 our @logs;
732 411         4428 our $nlo;
733              
734 411 100 100     6732 if( length($ki) and ! defined $val ) {
735 4 50 66     19 push @logs, "~~> l.$.".' NOT defined %%%V:'. $ki if $DEBUG && $op->{def};
736 4         12 return;
737             }
738              
739             # output head of variable
740 407         3235 &_ht_print( $fh, $el, 'head', $border );
741              
742             # output value of variable
743 407         1173 &_v_print; # ( $fh, $ki, $val, $el, $op );
744              
745             # output tail of variable
746 407         912 &_ht_print( $fh, $el, 'tail', 0);
747             }
748              
749              
750             sub _s_a_prn {
751 197     197   542 my( $fh, $i, $values, $el, $op, $border, $col ) = @_;
752              
753 197         417 my $val = $values->[$i];
754 197 100       478 $val = $$val if ref $val eq 'SCALAR';
755              
756 197 100       482 if( ref \$val eq 'SCALAR') {
    50          
757 195         592 &_hvt_print( $fh, $i, $val, $el, $op, $$border );
758 195         352 ++$$col;
759 195         831 $$border = 0;
760             }
761             elsif( ref $val eq 'ARRAY') { # [...].ARRAY.ARRAY
762 2         5 for( @$val ) {
763 17 50       48 next if ref \$_ ne 'SCALAR';
764              
765 17         52 &_hvt_print( $fh, $i, $_, $el, $op, $$border );
766 17         34 ++$$col;
767 17         43 $$border = 0;
768             }
769             }
770              
771             }
772              
773              
774             sub _mixed_indices {
775 123     123   359 my( $fh, $ki, $values, $el, $op, $border ) = @_;
776              
777 123         263 my $nd = @$values;
778 123         215 my $col = 0;
779              
780 123         446 for my $ii ( split ',', $ki ) { # e.g. -1-,1-3,6-7-9,-,4,-5,0,7-
781 139 100       355 next if $ii eq '-';
782              
783 138 100       381 if( $ii =~/^(\-[1-9]\d*)\-(\d*)$/) { # -1- i.e. reverse: -1,-2,..-@arr (i.e. arr_start)
784 12         39 my $s = $1;
785 12   66     62 my $e = -1*($2 || $nd);
786 12 100       62 $s = -1*$nd if abs($s) > $nd;
787 12 100       50 $e = -1*$nd if abs($e) > $nd;
788 12 100       54 ($s, $e) = ($e, $s) if $e > $s;
789              
790 12         42 for( my $i = $s; $i >= $e; --$i ) {
791 38         132 &_s_a_prn( $fh, $i, $values, $el, $op, \$border, \$col );
792             }
793 12         38 next;
794             }
795              
796 126 100       323 if( $ii =~/^\-[0-9]+$/ ) { # -5
797 1         5 my $i = $ii+0;
798              
799 1 50       6 if( abs($i) <= $nd ) {
800 1         4 &_s_a_prn( $fh, $i, $values, $el, $op, \$border, \$col );
801             }
802 1         3 next;
803             }
804              
805 125         422 my @n = grep{length} sort{$a <=> $b} split '-', $ii;
  126         481  
  1         6  
806              
807 125 100 66     609 if( @n < 2 and $n[0] < $nd ) { # e.g. 4 || 0 || 7(-)
808 124 100       327 if( $ii =~/\-$/) { # 7(-)
809              
810 17         60 for( my $i = $n[0]; $i < $nd; ++$i ) {
811 49         129 &_s_a_prn( $fh, $i, $values, $el, $op, \$border, \$col );
812             }
813              
814             }
815             else { # 4 || 0
816 107         293 &_s_a_prn( $fh, $n[0], $values, $el, $op, \$border, \$col );
817             }
818              
819             }
820             else { # 1-3 ->(1..3) || 6-7-9 ->(6..9)
821 1         6 for( my $i = $n[0]; $i <= $n[-1]; ++$i ) {
822 2         8 &_s_a_prn( $fh, $i, $values, $el, $op, \$border, \$col );
823             }
824             }
825              
826             }
827              
828 123         537 return $col;
829             }
830              
831              
832             sub _var_output {
833 70     70   233 my( $fh, $key, $vardata, $columns, $op ) = @_;
834 70 100       248 my $values = (ref $vardata eq 'HASH') ? $vardata->{ $key } : $vardata->[ $key ];
835              
836 70 50       191 @$columns or return;
837              
838 70         116 our $DEBUG;
839 70         111 our @logs;
840 70         116 our $nlo;
841              
842 70 100 100     331 if( ref \$values eq 'SCALAR' or ref $values eq 'SCALAR') { # key => SCALAR
843 26         112 &_hvt_print( $fh, $key, $values, $columns->[0], $op );
844 26         67 return;
845             }
846              
847 44 100       206 if( ref $values eq 'ARRAY') { # key => ARRAY
    50          
848              
849 35 100       93 unless( @$values ) {
850 1 50 33     12 push @logs, "~~> l.$. WARNING#7: empty ARRAY of %%%VAR:". $key if $DEBUG or ! $op->{ignore};
851 1         3 return;
852             }
853              
854             # Forming a table
855 34         64 my $row = 0;
856 34         67 my $nd = @$values;
857              
858             _var_output_M0:
859 34         87 foreach my $d ( @$values ) { # loop through table rows
860              
861 89 100       261 push @logs, '--> Table row = '. $row if $DEBUG;
862              
863 89         177 my $col = 0;
864 89         201 foreach my $el ( @$columns ) { # loop through table columns (for ARRAY.HASH) or rows (for ARRAY.SCALAR)
865              
866 260         598 my $ki = $el->{ki};
867 260 100 100     949 my $border = ((! $row and ! $col) or ($row >= $#{ $values } and (!defined( $ki ) or !length( $ki )) ) ) ? 1 : 0;
868              
869 260         482 my $val;
870 260 100       554 if( defined $ki ) {
871 223 100 100     1292 if( ref \$d eq 'SCALAR' or ref $d eq 'SCALAR') { # (ARRAY.SCALAR or ARRAY.REF->SCALAR) in regular vector
    100 66        
    50          
    0          
872              
873 25 50       131 if( $ki =~/^[\d,\-]+$/) {
874             # mixed indices, e.g.: 1-3,6-7-9,-,4,-5,0,7- or 3- (i.e. 3..arr_end) or 0-5 (0..5) or -1- (-1,-2,..arr_start)
875 25 100       112 last _var_output_M0 if $row;
876              
877 14 50       38 if( $_ = &_mixed_indices( $fh, $ki, $values, $el, $op, $border ) ) {
878 14         32 $col += $_ - 1;
879             }
880             }
881 14         36 next;
882             }
883             elsif( ref $d eq 'HASH' and defined( $d->{$ki} ) ) { # ARRAY.HASH
884 89         221 $val = $d->{$ki};
885              
886 89 100       348 if( ref $val eq 'ARRAY') { # ARRAY.HASH.ARRAY
    50          
887 2         7 for my $vv ( @$val ) {
888 14 50       37 next unless ref \$vv eq 'SCALAR';
889              
890 14         43 &_hvt_print( $fh, $ki, $vv, $el, $op, $border );
891 14         27 ++$col;
892             }
893 2         8 next;
894             }
895             elsif( ref \$val ne 'SCALAR') { # TODO for REF
896 0         0 next;
897             }
898             }
899             elsif( ref $d eq 'ARRAY') { # ARRAY.ARRAY
900              
901 109 50       635 if( $ki =~/^[\d,\-]+$/) {
902             # mixed indices, e.g.: 1-3,6-7-9,-,4,-5,0,7- or 3- (i.e. 3..arr_end) or 0-5 (0..5) or -1- (-1,-2,..arr_start)
903 109 50       264 $_ = &_mixed_indices( $fh, $ki, $d, $el, $op, $border ) and $col += $_ - 1;
904             }
905              
906 109         260 next;
907             }
908             elsif( $op->{def} ) {
909              
910 0 0       0 push @logs, "~~> l.$. NOT defined %%%V:". $ki if $DEBUG;
911              
912 0         0 next;
913             }
914             }
915             else {
916             # empty parameter -- at the very end of the columns (parameters)
917 37         89 $ki = '';
918             }
919              
920 124         361 &_hvt_print( $fh, $ki, $val, $el, $op, $border );
921             }
922             continue {
923 249         545 ++$col;
924             }
925             }
926             continue {
927 78         202 ++$row;
928             }
929              
930             }
931             elsif( ref $values eq 'HASH') {
932              
933 9         19 my $col = 0;
934 9         27 foreach my $el ( @$columns ) { # loop through parameters of %%%VAR-structure
935              
936 27         63 my $ki = $el->{ki};
937 27 100 100     82 my $border = ( ! $col or ($col >= $#{ $columns } and (!defined( $ki ) or !length( $ki )) )) ? 1 : 0;
938              
939 27         55 my $val;
940 27 100       66 if( defined $ki ) {
941 24 100 66     138 if( ref \$values->{$ki} eq 'SCALAR' and defined( $values->{$ki} )) { # HASH.SCALAR
    100 66        
    50 33        
    0          
942 21         49 $val = $values->{$ki};
943             }
944 1         5 elsif( ref $values->{$ki} eq 'SCALAR' and defined( ${ $values->{$ki} } )) { # HASH.REF->SCALAR
945 1         3 $val = ${ $values->{$ki} };
  1         3  
946             }
947             elsif( $ki eq '@' and ref $values->{'@'} eq 'ARRAY') {
948 2         4 for my $k ( @{ $values->{'@'} } ) {
  2         7  
949 11 100 66     63 next unless defined($k) && exists( $values->{$k} );
950              
951 10         54 my $v;
952 10 100       38 if( ref \$values->{$k} eq 'SCALAR') {
    100          
    50          
953 8         17 $v = $values->{$k};
954             }
955             elsif( ref $values->{$k} eq 'SCALAR') {
956 1         2 $v = ${ $values->{$k} };
  1         4  
957             }
958             elsif( $op->{def} ) {
959 0 0       0 push @logs, "-->\tl.$. ". 'NOT HASH.ARRAY.SCALAR %%%V:@->{'.$k."} in %%%VAR:". $key if $DEBUG;
960              
961 0         0 next;
962             }
963              
964 10         34 &_hvt_print( $fh, $k, $v, $el, $op, $border );
965 10         20 $border = 0;
966             }
967 2         6 next;
968             }
969             elsif( $op->{def} ) {
970 0 0       0 push @logs, "~~> l.$. NOT HASH.SCALAR or NOT defined %%%V:". $ki if $DEBUG;
971              
972 0         0 next;
973             }
974             }
975             else {
976             # empty parameter -- at the very end of the columns (parameters)
977 3         7 $ki = '';
978             }
979              
980 25         61 &_hvt_print( $fh, $ki, $val, $el, $op, $border );
981             }
982             continue {
983 27         65 ++$col;
984             }
985             }
986              
987             }
988              
989             1;
990              
991             __END__