source: genappalpha/etc/perl/genapp_util.pl @ 1491

Last change on this file since 1491 was 1491, checked in by ehb, 2 years ago

remove debugging messages

File size: 54.4 KB
Line 
1#** @file genapp_util.pl
2#   @brief This file includes all utilities for parsing the json file structure
3#   
4#*
5
6# user definition
7
8my $max_repeater_depth = 25;
9
10# subroutines for general usage
11
12use JSON;
13#use JSON::PP;
14
15# use Switch;
16# use Data::Dumper;
17use Hash::Merge qw( merge );
18Hash::Merge::set_behavior( 'RIGHT_PRECEDENT' );
19
20my $gap_version = '0.01';
21
22%__json_scratch = {};
23
24sub load_reserved_words {
25    my $fh;
26    my $f = "$gap/etc/reserved_words";
27    return "$f not found, will not be applied" if !-e $f;
28    open $fh, "$f";
29    while ( my $l = <$fh> )
30    {
31        next if $l =~ /^\s*#/;
32        chomp $l;
33        $reserved_words{ $l }++ if length( $l );;
34    }
35    "";
36}
37
38sub show_state {
39    my $ref   = $_[ 0 ];
40    my $tag   = $_[ 1 ];
41    my $depth = $_[ 2 ];
42#    print "$tag: d $depth state of __json_scratch\{ $ref \}:\n";
43    print "d $depth: $tag: size of array: " . scalar @{$__json_scratch{ $ref }} . "\n";
44}
45
46# $debug_rplc++;
47
48sub json_expand_util {
49    my $json  = $_[ 0 ];
50    my $ref   = $_[ 1 ];
51    my $tag   = $_[ 2 ];
52    my $depth = $_[ 3 ];
53
54    print '-'x80 . "\n" if $debug_rplc;
55    print "d $depth json_expand util " . ref( $json ) . "\n" if $debug_rplc;
56    print '-'x80 . "\n" if $debug_rplc;
57    $$ref{ "skipinc" } = 0;
58
59    if ( ref( $json ) eq 'HASH' )
60    {
61        # make 2 pass, one pass for non-refs, 2nd for arrays
62        my @added;
63        while ( my ($k, $v ) = each %$json )
64        {
65            if ( !ref( $v ) )
66            {
67                my $ntag = ( $tag ? "$tag:" : "" ) . $k;
68                print '-'x60 . "\n" if $debug_rplc;
69                show_state( $ref, "pre adding hash element '$ntag' '$v'", $depth ) if $debug_rplc;
70                if ( $__json_scratch{ $ref }[ $$ref{ "pos" } ]{ $ntag } )
71                {
72                    $$ref{ "pos" }++;
73                    %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} =
74                        %{$__json_scratch{ $ref }[ $$ref{ "pos" } - 1 ]};
75                    $$ref{ "skipinc" } = 0;
76                }
77                $__json_scratch{ $ref }[ $$ref{ "pos" } ]{ $ntag } = $v;
78                push @added, $ntag;
79                show_state( $ref, "post adding hash element '$ntag' '$v'", $depth ) if $debug_rplc;
80            }
81        }
82        my $array_count = 0;
83        while ( my ($k, $v ) = each %$json )
84        {
85            if ( ref( $v ) eq 'HASH' )
86            {
87                my $ntag = ( $tag ? "$tag:" : "" ) . $k;
88                json_expand_util( $v, $ref, ( $tag ? "$tag:" : "" ) . $k, $depth + 1 );
89                print "d $depth: depth " . ( 1 + $depth ) . " HASH return from expand ARRAY on $ntag\n" if ref( $v ) eq 'ARRAY' && $debug_rplc;
90                print "d $depth: depth " . ( 1 + $depth ) . " HASH return from expand HASH on $ntag\n" if ref( $v ) eq 'HASH' && $debug_rplc;
91                print "my added " . ( join " ", @added ) . "\n" if $debug_rplc;
92#                print "try clear closed hash, tag $ntag ref = " . ref( $v ) . "\n" if $debug_rplc;
93#                if ( ref( $v ) eq 'ARRAY' )
94#                {
95## increment, clear out matching keys                   
96#                    print "clear closed hash\n" if $debug_rplc;
97#                    $$ref{ "pos" }++ if !$$ref{ "skipinc" };
98#                    $$ref{ "skipinc" } = 1;
99#                    %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} =
100#                        %{$__json_scratch{ $ref }[ $$ref{ "pos" } - 1 ]};
101#                    for ( grep /^$ntag/, keys %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} )
102#                    {
103#                        print "deleting hash key $_\n" if $debug_rplc;
104#                        delete ${$__json_scratch{ $ref }[ $$ref{ "pos" } ]}{ $_ };
105#                    }
106#                }               
107            }
108        }
109        while ( my ($k, $v ) = each %$json )
110        {
111            if ( ref( $v ) eq 'ARRAY' )
112            {
113                my $ntag = ( $tag ? "$tag:" : "" ) . $k;
114                if ( ref( $v ) eq 'ARRAY' )
115                {
116# allow for general usage, probably should be a warning if active field
117#                    if ( $array_count )
118#                    {
119#                        die "Error: only one ARRAY currently supported per hash found at $ntag in ?.json\n";
120#                    }
121                    $array_count++;
122                }
123                json_expand_util( $v, $ref, ( $tag ? "$tag:" : "" ) . $k, $depth + 1 );
124                print "d $depth: depth " . ( 1 + $depth ) . " HASH return from expand ARRAY on $ntag\n" if ref( $v ) eq 'ARRAY' && $debug_rplc;
125                print "d $depth: depth " . ( 1 + $depth ) . " HASH return from expand HASH on $ntag\n" if ref( $v ) eq 'HASH' && $debug_rplc;
126                print "my added " . ( join " ", @added ) . "\n" if $debug_rplc;
127                print "try clear closed array, tag $ntag ref = " . ref( $v ) . "\n" if $debug_rplc;
128                if ( ref( $v ) eq 'ARRAY' )
129                {
130# increment, clear out matching keys                   
131                    print "clear closed array ntag $ntag\n" if $debug_rplc;
132                    $$ref{ "pos" }++ if !$$ref{ "skipinc" };
133                    $$ref{ "skipinc" } = 1;
134                    %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} =
135                        %{$__json_scratch{ $ref }[ $$ref{ "pos" } - 1 ]};
136                    my $utag = $ntag;
137                    print "clear closed array, utag1 $utag\n" if $debug_rplc;
138                    $utag =~ s/\:\w*$//;
139                    print "clear closed array, utag $utag\n" if $debug_rplc;
140                    for ( grep /^$utag(:|$)/, keys %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} )
141                    {
142                        print "deleting hash key $_\n" if $debug_rplc;
143                        delete ${$__json_scratch{ $ref }[ $$ref{ "pos" } ]}{ $_ };
144                    }
145                }               
146            }
147        }
148    }
149    if ( ref( $json ) eq 'ARRAY' )
150    {
151        my @added;
152        for ( my $i = 0; $i < @$json; ++$i )
153        {
154            my $v = $$json[ $i ];
155            if ( ref( $v ) )
156            {
157                json_expand_util( $v, $ref, $tag, $depth + 1 );
158                print "d $depth: depth " . ( 1 + $depth ) . " ARRAY return from expand ARRAY on $tag\n" if ref( $v ) eq 'ARRAY' && $debug_rplc;
159                print "d $depth: depth " . ( 1 + $depth ) . " ARRAY return from expand HASH on $tag\n" if ref( $v ) eq 'HASH' && $debug_rplc;
160                print "my added " . ( join " ", @added ) . "\n" if $debug_rplc;
161                if ( ref( $v ) eq 'HASH' )
162                {
163# increment, clear out matching keys                   
164                    print "clear closed hash\n" if $debug_rplc;
165                    $$ref{ "pos" }++ if !$$ref{ "skipinc" };
166                    $$ref{ "skipinc" } = 1;
167                    %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} =
168                        %{$__json_scratch{ $ref }[ $$ref{ "pos" } - 1 ]};
169                    for ( grep /^$tag(:|$)/, keys %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} )
170                    {
171                        print "deleting hash key $_\n" if $debug_rplc;
172                        delete ${$__json_scratch{ $ref }[ $$ref{ "pos" } ]}{ $_ };
173                    }
174                    print "after delete pairs:\n" if $debug_rplc;
175                    while ( my ( $k1, $v1 ) = each %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} )
176                    {
177                        print "$k1 $v1\n" if $debug_rplc;
178                    }
179                }               
180            } else {
181                print '-'x60 . "\n" if $debug_rplc;
182                show_state( $ref, "pre adding array element '$tag' '$v'", $depth ) if $debug_rplc;
183                if ( $__json_scratch{ $ref }[ $$ref{ "pos" } ]{ $tag } )
184                {
185                    $$ref{ "pos" }++;
186                    %{$__json_scratch{ $ref }[ $$ref{ "pos" } ]} =
187                        %{$__json_scratch{ $ref }[ $$ref{ "pos" } - 1 ]};
188                    $$ref{ "skipinc" } = 0;
189                }
190                $__json_scratch{ $ref }[ $$ref{ "pos" } ]{ $tag } = $v;
191                push @added, $tag;
192                show_state( $ref, "post adding array element '$tag' '$v'", $depth ) if $debug_rplc;
193            }
194        }
195        if ( 0 ) {
196            for ( my $i = 0; $i < @$json; ++$i )
197            {
198                my $v = $$json[ $i ];
199                if ( ref( $v ) )
200                {
201                    json_expand_util( $v, $ref, $tag, $depth + 1 );
202                }
203            }
204        }
205    }
206}   
207
208undef %global_file_replace_cache;
209undef %global_file_replace_style_cache;
210undef %include_additional_files;
211
212sub replace_file_json_walk {
213    my ( $hash, $lang, $file ) = @_;
214    while (my ($k, $v) = each %$hash) {
215        if (ref($v) eq 'HASH') {
216            replace_file_json_walk( $v, $lang, $file );
217        } else {
218            if ( ref( $v ) eq 'ARRAY' ) {
219                for ( my $i = 0; $i < @$v; ++$i ) {
220                    replace_file_json_walk( @$v[$i], $lang, $file );
221                }
222            } else {
223                # at leaf node ... load file if needed
224                if ( $v =~ /^__<\s*(.*)\.(\S+)$/ ) {
225                    my $f = "files/$1.$2";
226                    my $type = $2;
227                    # print "---> file match found $f type $type\n";
228                    if ( $type !~ /^(txt|html|doc|docx)$/ ) {
229                        $error .= "Unsupported include file type found $type\n";
230                    } else {
231                        $f = "$lang/$f" if -e "$lang/$f";
232                        if ( $global_file_replace_cache{ $f } ) {
233                            $$hash{ $k } = $global_file_replace_cache{ $f };
234                        } else {
235                            if ( !-e $f ) {
236                                $error .= "Could not find include file $f\n";
237                            } else {
238                                if ( !-r $f ) {
239                                    $error .= "Could not read include file $f, check permissions\n";
240                                } else {
241                                    print "including file $f\n";
242                                    if ( $type =~ /^(txt|html)$/ ) {
243                                        # print "now include as text\n";
244                                        my $fh;
245                                        open $fh, $f || die "$0: error reading include file $f\n";
246                                        my @l = <$fh>;
247                                        close $fh;
248                                        my $body = join '', @l;
249                                        # escape single quotes, remove newlines
250                                        $body =~ s/'/\\'/g;
251                                        $body =~ s/\n/ /g;
252                                        # replace tilde's
253                                        $body =~ s/~/&#126;/g;
254                                        $global_file_replace_cache{ $f } = $body;
255                                        $$hash{ $k } = $body;
256                                        if ( !length( $global_file_replace_cache{ $f } ) ) {
257                                            $warn .= "Included file $f appears to be empty\n";
258                                        }
259                                    }
260                                    if ( $type =~ /^(doc|docx)$/ ) {
261                                        # print "now include as html from abiword\n";
262                                        my $uf = $file;
263                                        $file =~ s/\.json$//;
264                                        $file =~ s/^.*\///;
265                                        my $cmd = "doc2html.pl $file '$f'\n";
266                                        print $cmd;
267                                        my $fh;
268                                        open $fh, "doc2html.pl $file '$f' |";
269                                        my @l = <$fh>;
270                                        close $fh;
271                                        die "$0: error with image conversion of $f\n" if $?;
272                                       
273                                        my $od = $l[ 0 ];
274                                        chomp $od;
275                                        my $utag = $l[ 1 ];
276                                        chomp $utag;
277                                        print "od is '$od'\nutag is '$utag'\n";
278                                       
279                                        open $fh, "$od/$utag.html";
280                                        my @l = <$fh>;
281                                        close $fh;
282                                        my $body = join '', @l;
283
284                                        open $fh, "$od/$utag.css";
285                                        my @l = <$fh>;
286                                        close $fh;
287                                        my $style = join '', @l;
288
289                                        if ( -e "$od/${utag}_files" ) {
290                                            my @fs = `cd $od/${utag}_files; ls -1`;
291                                            grep chomp, @fs;
292                                            grep s/^/${utag}_files\//, @fs;
293                                            # print join "\n", @fs;
294                                            # print "\n";
295                                            foreach my $k ( @fs ) {
296                                                $include_additional_files{ "$od/$k" } = "files/$k";
297                                                $body =~ s/$k/files\/$k/g;
298                                            }
299                                            #foreach my $k ( keys %include_additional_files ) {
300                                            #    print "\$include_additional_files{ $k } = $include_additional_files{$k}\n";
301                                            #}
302                                        }
303
304                                        # escape single quotes, remove newlines
305                                        $body  =~ s/'/\\'/g;
306                                        $body  =~ s/\n/ /g;
307                                        $style =~ s/'/\\'/g;
308                                        $style =~ s/\n/ /g;
309                                        $global_file_replace_cache{ $f }          = $body;
310                                        $global_file_replace_cache_style{ $file } .= $style;
311
312                                        # print "style is:----------------------------------------\n$style\n----------------------------------------\n";
313                                        # print "body is:----------------------------------------\n$body\n----------------------------------------\n";
314                                       
315                                        if ( !length( $global_file_replace_cache{ $f } ) ) {
316                                            $warn .= "Included file $f appears to be empty after abiword processing\n";
317                                        }
318
319                                        if ( 0 ) { # old way
320                                            my $uf = $f;
321                                            $uf =~ s/ /\\ /g;
322                                            my $fh;
323                                            open $fh, "abiword --to=html --to-name=fd://1 --exp-props='html-markup: html4; html-images: embed' $uf 2> /dev/null |" || die "$0: error reading include file $f\n";
324                                            my @l = <$fh>;
325                                            close $fh;
326                                            my $res = join '', @l;
327                                            ( my $style ) = $res =~ /<style type="text\/css">((.|\n)*)<\/style>/m;
328                                            ( my $body ) = $res =~ /<body>((.|\n)*)<\/body>/m;
329                                            # escape single quotes, remove newlines
330                                            $body  =~ s/'/\\'/g;
331                                            $body  =~ s/\n/ /g;
332                                            $style =~ s/'/\\'/g;
333                                            $style =~ s/\n/ /g;
334                                            $global_file_replace_cache{ $f }          = $body;
335                                            $global_file_replace_cache_style{ $file } .= $style;
336#                                        print "style is:\n$style\n";
337#                                        print "in walk global_file_replace_cache_style:\n" . Dumper( %global_file_replace_cache_style );
338                                            $$hash{ $k } = $body;
339                                            if ( !length( $global_file_replace_cache{ $f } ) ) {
340                                                $warn .= "Included file $f appears to be empty after abiword processing\n";
341                                            }
342                                        }
343                                    }
344                                }
345                            }
346                        }
347                    }
348                }
349            }
350        }
351    }
352    $hash;
353}
354
355#** @function public start_json ( json , ref )
356#
357# @brief takes json and initiates an iterator
358#
359# This starts an iterator thru the json
360# rewind the iterator with rewind_json()
361# increment the iterator with next_json()
362#
363# @param json required a decoded_json HASH e.g. a return from get_file_json()
364# @param ref  required a an empty hash to store the iterator
365# @retval ref the initialized iterator
366#*
367
368sub start_json {
369    my $json = $_[0];
370    my $ref  = $_[1];    # a reference to a HASH
371   
372    my $error;
373    if ( ref( $json ) ne 'HASH' )
374    {
375        $error .= "start_json argument 1 is not a HASH\n";
376    }
377    if ( ref( $ref ) ne 'HASH' )
378    {
379        $error .= "start_json argument 2 is not a HASH\n";
380    }
381    die $error if $error;
382
383    $__json_scratch{ $ref } = (); # an array of pairs
384    $$ref{ "pos" }     = 0;
385    $$ref{ "skipinc" } = 0;
386
387    json_expand_util( $json, $ref );
388    if ( $$ref{ "pos" } ) # -1 to take care of last closer ?
389    {
390        $__json_scratch{ $ref }[ $$ref{ "pos" } ] = 0;
391        $$ref{ "pos" }--;
392#        pop( $__json_scratch{ $ref } );
393    }
394    $$ref{ "mpos" } = $$ref{ "pos" };
395    $$ref{ "pos" } = 0;
396#    print "ref( $json ) is " . ref( $json ) . "\n";
397#    print "ref( $ref ) is " . ref( $ref ) . "\n";
398    $__json_scratch{ $ref }[ $$ref{ "pos" } ];
399}
400
401#** @function public rewind_json ( ref )
402#
403# @brief rewinds the json iterator
404#
405# @param ref the iterator HASH reference
406# @retval ref the iterator set back to the start
407#
408# @bug needs testing
409#*
410
411sub rewind_json {
412    my $ref = $_[0];
413    $$ref{ "pos" } = 0;
414    return $__json_scratch{ $ref }[ $$ref{ "pos" } ];
415}
416
417#** @function public copy_json ( ref )
418#
419# @brief makes a copy
420#
421# @param ref the iterator HASH reference
422# @retval ref the iterator set back to the start
423#
424#*
425
426sub copy_json {
427    my $org_ref = $_[ 0 ];
428    my $new_ref = $_[ 1 ];
429    $__json_scratch{ $new_ref } = [ @$__json_scratch{ $org_ref } ];
430}
431
432#** @function public next_json ( ref, match )
433#
434# @brief moves to the next matched block of json
435#
436# @param ref the iterator HASH reference
437# @param match the string to check for iteration forward
438# @retval ref the iterator moved forward
439#
440#*
441
442sub next_json {
443    my $ref   = $_[ 0 ];
444    my $match = $_[ 1 ];
445    my @match = split '\|', $match;
446
447    if ( !$match )
448    {
449        $$ref{ "pos" }++;
450    } else {
451        my @v;
452        for ( my $i = 0; $i < @match; ++$i )
453        {
454            $v[ $i ] = $__json_scratch{ $ref }[ $$ref{ "pos" } ]{ $match[ $i ] };
455        }
456#        print "start next json: match: " . ( join '~', @match ) . "\n";
457#        print "start next json: v    : " . ( join '~', @v     ) . "\n";
458        my $goon = 1;
459        do {
460            $$ref{ "pos" }++;
461            for ( my $i = 0; $i < @match; ++$i )
462            {
463                if (  $__json_scratch{ $ref }[ $$ref{ "pos" } ]{ $match[ $i ] } ne $v[ $i ] )
464                {
465                    $goon = 0;
466                    last;
467                }
468            }
469        } while ( $$ref{ "pos" } < $$ref{ "mpos" } && $goon );
470        if ( $goon )
471        {
472            return 0;
473        }
474#        print "end of match check: pos " . $$ref{ "pos" } . " mpos: " . $$ref{ "mpos" } . "\n";
475    }
476    return $__json_scratch{ $ref }[ $$ref{ "pos" } ];
477}   
478
479
480sub get_replacements {
481    my $t = $_[ 0 ];
482    if ( ref( $t ) ne 'ARRAY' )
483    {
484        my @r = split "\n", $t;
485        return get_replacements( \@r );
486    }
487    my %used;
488    my @ret;
489    foreach my $k ( @$t )
490    {
491        while ( ( $tok ) = $k =~ /__([a-z0-9:]+)__/ )
492        {
493            push @ret, $tok if !$used{ $tok }++;
494            $k =~ s/__${tok}__//g;
495            print "k after removal of __${tok}__ is $k\n" if $debug_rplc;
496        }
497    }
498    \@ret;
499}
500
501sub test_get_replacements {
502    my @l = (
503        "__line1__",
504        "__line2__line3a__",
505        "__line2____line3b__",
506        "__tagx__ __tagy__"
507        );
508    my $r = get_replacements( \@l );
509    print "test_get_replacements:\n";
510    for ( my $i = 0; $i < @$r; ++$i )
511    {
512        print "$$r[ $i ]\n";
513    }
514}
515
516sub fix_up_sub_tok {
517    my $tok = $_[ 0 ];
518    $tok =~ s/\\/\\\\/g;
519    $tok =~ s/\+/\\+/g;
520    $tok =~ s/\(/\\(/g;
521    $tok =~ s/\)/\\)/g;
522    $tok =~ s/\*/\\*/g;
523    $tok =~ s/\{/\\{/g;
524    $tok =~ s/\}/\\}/g;
525    $tok =~ s/\^/\\^/g;
526    $tok =~ s/\$/\\\$/g;
527    $tok =~ s/\[/\\[/g;
528    $tok =~ s/\]/\\]/g;
529    $tok =~ s/\?/\\?/g;
530    $tok;
531}
532
533sub get_cond_replacements {
534#    $debug_rplc++;
535    my $t = $_[ 0 ];
536    if ( ref( $t ) ne 'ARRAY' )
537    {
538        my @r = split "\n", $t;
539        return get_cond_replacements( \@r );
540    }
541    my %used;
542    my %ret;
543    my @l = @$t; # make copy to avoid side effect of destroying fields
544    foreach my $k ( @l )
545    {
546        print '-'x30 . "\n" . "testing: <$k>\n" if $debug_rplc;
547#        while ( ( $tok1, $tok2 ) = $k =~ /__\~([a-z0-9:]+)\s*\{([a-zA-Z0-9_=\"\': \+\-\(\)\*;%\.>]+)/ )
548#        while ( ( $tok1, $tok2 ) = $k =~ /__\~([a-z0-9:_]+)\s*\{(([a-zA-Z0-9_=\"\': \+\-\(\)\*;#%\.\,\^>\/<~\?\\\$\[\]&]|\{[^\}]*\})+)\}/ )
549
550# works for arbitrary sets:    my @array = $k =~ /\{ ( (?: [^{}]* | (?0) )* ) \}/x;
551
552        if ( 1 ) {
553            while ( ( $tok1 ) = $k =~ /__\~([a-z0-9:_]+)\s*\{/ )
554            {
555                print "--- tok1 is $tok1\n" if $debug_rplc;
556                if ( $used{ $tok1 }++ )
557                {
558                    die "Error: multiple condition replacements for $tok1 in $k\n";
559                }
560                my $k1 = $k;
561                $k1 =~ s/^.*__~${tok1}\s*\{/\{/;
562                print "--- k1 is  $k1\n" if $debug_rplc;
563                ( $tok2 ) = $k1 =~  /\{ ( (?: [^{}]* | (?0) )* ) \}/x;
564                print "--- tok1 $tok1 : $tok2\n" if $debug_rplc;
565                die "Error: empty tok2 in condition replacement of $tok1\n" if !length( $tok2 );
566                $ret{ $tok1 } = $tok2;
567                my $tok2r = fix_up_sub_tok( $tok2 );
568                print "tok2r is $tok2r\n" if $debug_rplc;
569                $k =~ s/__~${tok1}\s*\{$tok2r\}//g;
570                print "k after removal of __~${tok1}\s*\{$tok2\} is '$k'\n" if $debug_rplc;
571            }
572        } else {
573            while ( ( $tok1, $tok2 ) = $k =~ /__\~([a-z0-9:_]+)\s*\{(([a-zA-Z0-9_=\"\': \+\-\(\)\*;#%\.\,\^>\/<~\?\\\$\[\]&]|\{[^\}]*\})+)\}/ )
574            {
575                print "--- tok1 $tok1 : $tok2\n" if $debug_rplc;
576                if ( $used{ $tok1 }++ )
577                {
578                    die "Error: multiple condition replacements for $tok1\n";
579                }
580                $ret{ $tok1 } = $tok2;
581                my $tok2r = fix_up_sub_tok( $tok2 );
582                $k =~ s/__~${tok1}\s*\{$tok2r\}//g;
583                print "k after removal of __~${tok1}\s*\{$tok2\} is $k\n" if $debug_rplc;
584            }
585        }
586        print "testing <$k> done\n" . '-'x30 . "\n" if $debug_rplc;
587    }
588    undef $debug_rplc;
589    \%ret;
590}
591
592sub test_get_cond_replacements {
593    my @l = (
594        '__~myrplc2{ max="__max2__"} midstuff __~myrplc3{ max="__max2__"}'
595        ,'extrapre __~myrplc4{{{}}} extrapost'
596        ,'__~myrplc3b{"{{}}"}'
597        ,'__~myrplcxy'
598        ,'__~myrplcxy2{ max="__hi__"}'
599        ,'__~myrplc1{ max="__max__"}'
600        ,'__~myrplc2a{ max="__max__"}__~myrplc3a{ max="__max__"}'
601        );
602    print "test_get_cond_replacements:\n";
603    $debug_rplc++;
604    my $r = get_cond_replacements( \@l );
605    while( my ( $k, $v ) = each %$r )
606    {
607        print "$k => $v\n";
608    }
609}
610
611sub mkdir_for_file {
612    my $f = $_[ 0 ];
613    my @l = split '/', $f;
614    my $p;
615    for ( my $i = 0; $i < @l -1; ++$i )
616    {
617        $p .= "/" if $p;
618        $p .= $l[ $i ];
619        if ( !-d $p )
620        {
621            if ( -e $p )
622            {
623                die "Error: creating directory $p, it is not a directory and already exists\n";
624            }
625            if ( ! mkdir $p )
626            {
627                die "Error: creating directory $p $!\n";
628            }
629            $notice .= "created directory $p\n";
630        }
631    }
632}
633
634sub print_json_expand {
635    my $arg = $_[ 0 ];
636    my $pos = $_[ 1 ];
637    if ( ref( $arg ) eq 'HASH' )
638    {
639        while ( my ($k, $v ) = each %$arg )
640        {
641            if ( ref( $v ) )
642            {
643                print '-'x$pos . "$k is a ref:\n";
644                print_json_expand( $v, $pos + 1 );
645            } else {
646                print '-'x$pos . "$k is $v\n";
647            }
648        }
649    }
650    if ( ref( $arg ) eq 'ARRAY' )
651    {
652        for ( my $i = 0; $i < @$arg; ++$i )
653        {
654            my $v = $$arg[ $i ];
655            if ( ref( $v ) )
656            {
657                print '-'x$pos . "[$i] is a ref:\n";
658                print_json_expand( $v, $pos + 1 );
659            } else {
660                print '-'x$pos . "[$i] is $v\n";
661            }
662        }
663    }
664}   
665
666#** @function public get_file_json (filename, filename2 )
667# @brief opens json formatted file and returns the json decoded as a HASH
668#
669# opens json formatted file and returns the json decoded as a HASH
670# will die if file does not exist
671#
672# @param filename required the file to open
673# @param filename2 optional the file to append
674# @retval json the json decoded as a HASH
675#*
676
677sub get_file_json {
678    my $f  = $_[ 0 ];
679    my $f2 = $_[ 1 ];
680
681    $get_file_json_last = $f;
682
683    die "$0: get_file_json error $f does not exist\n" if !-e $f;
684    my $fh;
685    open $fh, $f || die "$0: get_file_json error file open $f $!\n";
686    my @ol = <$fh>;
687    close $fh;
688    my @l = grep !/^\s*#/ , @ol;
689    my $l = join '', @l;
690    my $json;
691    eval {
692        $json = decode_json( $l );
693        1;
694    } || do {
695        my $e = $@;
696       
697        # figure out line #
698
699        my ( $cp ) = $e =~ /at character offset (\d+) /;
700        my $i;
701        my $cpos = $cp;
702        for ( $i = 0; $i < @ol; ++$i ) {
703            next if $ol[ $i ] =~ /^\s*#/;
704            $cpos -= length( $ol[ $i ] );
705            last if $cpos < 0;
706        }
707
708        my $sline = $i - 2;
709        my $eline = $i + 2;
710        $sline = 0 if $sline < 0;
711        $eline = @ol - 1 if $eline >= @ol;
712
713        print "JSON Error in file $f near these lines:\n";
714        for ( my $j = $sline; $j <= $eline; ++$j ) {
715            my $uj = $j + 1;
716            print "$uj: $ol[$j]";
717            print "$uj: " .'^'x(length($ol[$j])) . "\n" if $j == $i;
718        }
719        die;
720    };
721
722    if ( $f2 ) {
723        die "$0: get_file_json error $f2 does not exist\n" if !-e $f2;
724        my $fh;
725        open $fh, $f2 || die "$0: get_file_json error file open $f2 $!\n";
726        my @l = <$fh>;
727        close $fh;
728        @l = grep !/^\s*#/ , @l;
729        my $l = join '', @l;
730        $json = merge( $json, decode_json( $l ) );
731        $get_file_json_last .= " merged with $f2";
732    }
733
734    # remove tags with structures and store in last_json
735
736    if ( $$json{ 'dependencies' } ) {
737        my $js = JSON->new;
738        $extra_subs{ '__dependencies__' } = $js->encode( $$json{ 'dependencies' } );
739        delete $$json{ 'dependencies' };
740    } else {
741        delete $extra_subs{ '__dependencies__' };
742    }
743       
744    $json;
745}
746
747sub get_lang_json {
748    get_file_json( "$gap/languages/$_[0].json" );
749}
750
751#** @function public get_file_json_lang_specific (filename, language, replace )
752# @brief opens json formatted file and returns the json decoded as a HASH
753#
754# opens json formatted file and returns the json decoded as a HASH
755# checks first for language/filename and if it doesn't exist, tries filename
756# if "replace" evalutes true, the language specific json replaces, otherwise, it is appended
757# will die if file does not exist
758#
759# @param filename required the file to open
760# @param language required the target language
761# @param replace something that evaulates true if you wish use the language specific contents as a replacement
762# @retval json the json decoded as a HASH
763#*
764
765sub get_file_json_lang_specific {
766    my $f = $_[ 0 ];
767    my $l = $_[ 1 ];
768    my $r = $_[ 2 ];
769
770#    print "get_file_json_lang_specific f='$f' l='$l' r='$r'\n";
771
772    if ( $l && -e "$l/$f" ) {
773        $get_file_json_lang_specific_used++;
774        return replace_file_json_walk( $r ? get_file_json( "$l/$f" ) : get_file_json( "$f", "$l/$f" ), $l, $f );
775    }
776
777    replace_file_json_walk( get_file_json( "$f" ), $l, $f );
778}
779
780# $debugref++;
781
782sub ref_match {
783    my $arg   = $_[ 0 ];
784    my $match = $_[ 1 ];
785    my $tag   = $_[ 2 ];
786    my $pos   = $_[ 3 ];
787
788    my @ret;
789   
790    $tag = "base" if !length( $tag );
791
792    if ( ref( $arg ) eq 'HASH' )
793    {
794        while ( my ($k, $v ) = each %$arg )
795        {
796            if ( $k eq $match )
797            {
798                push @ret, $v;
799            }
800            if ( ref( $v ) )
801            {
802                print '-'x$pos . "$k is a ref:\n" if $debugref;
803                my $x = ref_match( $v, $match, $k, $pos + 1 );
804                foreach my $k ( @$x )
805                {
806                    push @ret, $k;
807                }
808            } else {
809                print '-'x$pos . "<[$tag]> <$k> is $v\n" if $debugref;
810            }
811        }
812    }
813    if ( ref( $arg ) eq 'ARRAY' )
814    {
815        for ( my $i = 0; $i < @$arg; ++$i )
816        {
817            my $v = $$arg[ $i ];
818            if ( ref( $v ) )
819            {
820                print '-'x$pos . "[$i] is a ref:\n" if $debugref;
821                my $x = ref_match( $v, $match, $tag, $pos + 1 );
822                foreach my $k ( @$x )
823                {
824                    push @ret, $k;
825                }
826            } else {
827                print '-'x$pos . "<[$tag]> [$i] is $v\n" if $debugref;
828            }
829        }
830    }
831
832    \@ret;
833}   
834
835sub hash_simple {
836# for single pair info
837    my $x = ref_match( $_[ 0 ], $_[ 1 ] );
838    my %ret;
839    foreach my $k ( @$x )
840    {
841        $ret{ $k }++ if !ref( $k );
842        if ( ref( $k ) eq 'ARRAY' )
843        {
844            foreach my $j ( @$k )
845            {
846                $ret{ $j }++ if !ref( $j );
847            }
848        }
849    }
850    \%ret;
851}
852
853sub hash_sub {
854    my $modules = ref_match( $_[ 0 ], $_[ 1 ], $_[ 2 ] );
855    my %ret;
856
857    foreach my $k ( @$modules )
858    {
859        if ( ref( $k ) eq 'ARRAY' )
860        {
861            foreach my $j ( @$k )
862            {
863                if ( ref( $j ) eq 'HASH' )
864                {
865                    while( my ( $k, $v ) = each %$j )
866                    {
867                        $ret{ $v }++ if !ref( $v ) && $k eq $_[ 2 ];
868                    }
869                }
870            }
871        }
872    }
873    \%ret;
874}
875   
876sub valid_name {
877    my $context = $_[ 0 ];
878    my $ref     = $_[ 1 ];
879    my $error;
880    my %tmpref;
881
882    if ( ref( $ref ) eq 'SCALAR' )
883    {
884        $ref = { $$ref => 1 };
885    }
886
887    if ( ref( $ref ) eq 'ARRAY' )
888    {
889        my $bref = $ref;
890        $ref = {};
891        foreach my $k ( @$bref )
892        {
893            $$ref{ $k }++;
894        }
895    }
896    foreach my $k ( keys %$ref )
897    {
898        if ( $k !~ /^[A-Za-z]\w*$/ )
899        {
900            $error .= "in context $context: invalid name '$k' must alphabetic in first space and contain only alphanumeric or underscore\n";
901        }
902        if ( $reserved_words{ $k } )
903        {
904            $error .= "in context $context: invalid name '$k' reserved word\n";
905        }
906    }
907    $error;
908}
909
910
911#** @function public svninfo ( path )
912#
913# @brief changes to the path and returns a nice svn info
914#
915# @param string path required the directory to check
916# @retval string the info, empty if no svn there
917#*
918
919sub svninfo {
920    my $path = $_[0];
921    my $info = `cd $path; svn info 2> /dev/null`;
922    ( my $rev ) = $info =~ /^Revision: (\d+)/m;
923    ( my $revdate ) = $info =~ /^Last Changed Date: (.*)$/m;
924#    print "svn path $path rev $rev date $revdate\n";
925    my $ret = "";
926    if ( length( $rev ) && length( $revdate ) ) {
927        $ret = "Revision $rev on $revdate";
928    }
929    $ret;
930}
931
932sub module_exists {
933    my $f     = $_[0];
934    my $langs = $_[1];
935
936    return 1 if -e $f;
937
938    foreach my $k ( keys %$langs ) {
939        return 1 if -e "$k/$f";
940    }
941    return 0;
942}
943
944sub add_special_directives {
945    my $json = $_[0];
946
947    foreach my $k ( keys %special_directives ) {
948        $$json{ $k } = $special_directives{ $k };
949    }
950    $json;
951}
952
953sub get_available_module_files {
954    my $f     = $_[0];
955    my $langs = $_[1];
956
957    my %avail_module_files;
958
959    # ok, it's going to check them all... should really only check used ones based upon menu
960
961    $avail_module_files{ $f }++ if -e $f;
962
963    foreach my $k ( keys %$langs ) {
964        $avail_module_files{ $f }++ if -e "$k/$f";
965    }
966    %avail_module_files;
967}
968
969sub check_files {
970    print "genapp_util.pl version $gap_version\n";
971
972    # global side-effects
973    undef %langs;
974    undef %icons;
975    undef %types;
976    undef $menu;
977    undef $config;
978    undef $configbase;
979    undef $directives;
980    undef %special_directives;
981    undef %rpls;
982    undef %module_to_file;
983    undef %reserved_words;
984
985    $notice .= load_reserved_words();
986
987#    my %modules;
988    my %modules_by_language;
989
990    my @req = (
991        'directives.json'
992#        ,'menu.json'
993        ,'config.json'
994        ,'configbase.json'
995    );
996
997    my $error;
998    undef $warn;
999
1000#    $error .= valid_name( 'testing', [ "hi", "there", "interface" ] );
1001
1002    my @further_checks;
1003    my $fh;
1004    foreach my $f ( @req )
1005    {
1006        if ( !-e $f )
1007        {
1008            if ( -e "$gap/modules/$f" )
1009            {
1010                $f = "$gap/modules/$f";
1011            } else {
1012                $error .= "$f does not exist\n";
1013                next;
1014            }
1015        }
1016        if ( ! open $fh, $f )
1017        {
1018            $error .= "$f can not be opened\n";
1019            next;
1020        }
1021        close $fh;
1022        push @further_checks, $f;
1023    }
1024
1025    my %already_pushed_menus;
1026
1027    foreach my $f ( @further_checks )
1028    {
1029        print '-'x60 . "\n";
1030        print "checking: $f\n";
1031        my $this_lang = $f =~ /^(.*)\/menu.json$/ ? $1 : "";
1032
1033        my $json = get_file_json( $f );
1034        print "get json $f: json $json\n";
1035        {
1036            my $x = hash_simple( $json, 'languages' );
1037            print "languages:\n\t" . ( join "\n\t", keys %$x ) . "\n" if keys %$x;
1038            foreach my $k ( keys %$x )
1039            {
1040                $langs{ $k }++;
1041                my $this_menu = -e "$k/menu.json" ? "$k/menu.json" : "menu.json";
1042                print "language $k this menu $this_menu\n";
1043                if ( !$already_pushed_menus{ $this_menu } ) {
1044                    print "language $k this menu $this_menu pushed to further checks\n";
1045                    $already_pushed_menus{ $this_menu }++;
1046                    push @further_checks, $this_menu;
1047                }
1048                # check directives.json in language if exists to make sure there is no language definition
1049                if ( -e "$k/directives.json" ) {
1050                    my $d_json = get_file_json( "$k/directives.json" );
1051                    my $d_x = hash_simple( $d_json, 'languages' );
1052                    $error .= "$k/directives.json can not contain a languages tag. this is only allowed in your base directives.json\n" if keys %$d_x;
1053                }
1054            }
1055        }
1056
1057        {
1058            my $x = hash_sub( $json, 'modules', 'id' );
1059            print "modules:\n\t" . ( join "\n\t", keys %$x ) . "\n" if keys %$x;
1060            $error .= valid_name( "$f modules:id", $x );
1061            foreach my $k ( keys %$x )
1062            {
1063                $modules_by_language{ $this_lang } = {} if !$modules_by_language{ $this_lang };
1064                $modules_by_language{ $this_lang }{ $k }++;
1065            }
1066        }
1067
1068        {
1069            my $x = hash_simple( $json, 'icon' );
1070            print "icons:\n\t" . ( join "\n\t", keys %$x ) . "\n" if keys %$x;
1071            foreach my $k ( keys %$x )
1072            {
1073                $icons{ $k }++;
1074            }
1075        }
1076
1077        # special file specific items
1078        if ( $f eq 'directives.json' )
1079        {
1080            $directives = $json;
1081            my @req = ( "title", "application", "version" );
1082            foreach my $k ( @req )
1083            {
1084                my $x = hash_simple( $json, $k );
1085                if ( keys %$x == 0 )
1086                {
1087                    $error .= "no $k found in $f\n";
1088                    next;
1089                }
1090                if ( keys %$x != 1 )
1091                {
1092                    $warn .= "multiple $k found: " . ( join ' ', keys %$x ) . " in $f\n";
1093                }
1094                $rpls{ $k } = each %$x;
1095                print "$k:\t". $rpls{$k} . "\n";
1096            }
1097            my @cnames = ( "application" );
1098            foreach my $k ( @cnames )
1099            {
1100                $error .= valid_name( "$f \"$k\"", \$rpls{$k} );
1101            }
1102            # add special tags
1103            {
1104                my $date = `date -u`;
1105                chomp $date;
1106                $special_directives{ 'generatedon' } = "Generated on $date";
1107                my $path = `pwd`;
1108                chomp $path;
1109                my $info = svninfo( $path );
1110                if ( length( $info ) ) {
1111                    $info = $$directives{ "title" } . " " . $info;
1112                }
1113                $special_directives{ 'apprevision' } = $info;
1114                print "info: $info\n";
1115                $info = "GenApp " . svninfo( $gap );
1116                $special_directives{ 'revision' } = $info;
1117                print "info: $info\n";
1118            }
1119        }
1120
1121        if ( $f =~ 'menu.json' )
1122        {
1123            $menu = $json;
1124            # check for menu.json issues
1125            my $ref_menu = {};
1126            my $rplc_menu = start_json( $menu, $ref_menu );
1127            my $freq = "menu:id";
1128            my %used_menu_ids;
1129            my %used_module_ids;
1130            do {
1131                $used_menu_ids{ $$rplc_menu{ $freq } }++;
1132            } while( $rplc_menu = next_json( $ref_menu, $freq ) );
1133            my $rplc_menu = start_json( $menu, $ref_menu );
1134            $freq = "menu:modules:id";
1135            do {
1136                $error .= "menu.json error: menu:id \"$$rplc_menu{$freq}\" is duplicated as a module:id\n"
1137                    if $used_menu_ids{ $$rplc_menu{ $freq } };
1138                $error .= "menu.json error: menu:module:id \"$$rplc_menu{$freq}\" is duplicated\n"
1139                    if $used_module_ids{ $$rplc_menu{ $freq } }++;
1140            } while( $rplc_menu = next_json( $ref_menu, $freq ) );
1141        }
1142
1143        if ( $f eq 'config.json' ||
1144             $f eq "$gap/modules/config.json" )
1145        {
1146            $config = $json;
1147        }
1148
1149        if ( $f eq 'configbase.json' ||
1150             $f eq "$gap/modules/configbase.json" )
1151        {
1152            $configbase = $json;
1153        }
1154    } # end further_checks
1155
1156#    print "modules_by_language:\n" . Dumper( \%modules_by_language );
1157#    print "keys modules_by_language:\n" . Dumper( keys  \%modules_by_language );
1158
1159    foreach my $k ( keys %langs )
1160    {
1161        my $f = "$gap/languages/$k.json";
1162        if ( !-e $f )
1163        {
1164            $error .= "missing language '$k' in $f \n";
1165            next;
1166        }
1167    }
1168
1169    my %module_files;
1170
1171    foreach my $l ( keys %{\%modules_by_language} ) {
1172#        print "l in modules_by_language is $l\n";
1173#        print Dumper ( %$l );
1174
1175        foreach my $k ( keys %{$modules_by_language{ $l }} ) {
1176# local dir modules take precedence
1177            my $f = "modules/$k.json";
1178            if ( !module_exists( $f, \%langs ) ) {
1179#            my $fg = "$gap/modules/" . $rpls{"application"} . "/$k.json";
1180                my $fg = "$gap/modules/$k.json";
1181                if ( !-e $fg )
1182                {
1183                    $error .= "missing module '$k' in $f or $fg\n";
1184                    next;
1185                } else {
1186                    $module_files{ $l } = {} if !$module_files{ $l };
1187                    $module_files{ $l }{ $fg }++;
1188                    $module_to_file{ $l } = {} if !$module_to_file{ $l };
1189                    $module_to_file{ $l }{ $k } = $fg;
1190                }
1191            } else {
1192                $module_files{ $l } = {} if !$module_files{ $l };
1193                $module_files{ $l }{ $f }++;
1194                $module_to_file{ $l } = {} if !$module_to_file{ $l };
1195                $module_to_file{ $l }{ $k } = $f;
1196            }
1197        }
1198    }
1199
1200#    print "module_files:\n" . Dumper( \%module_files );
1201#    print "module_to_file:\n" . Dumper( \%module_to_file );
1202
1203    foreach my $k ( keys %icons )
1204    {
1205        my $f = $k;
1206        if ( !-e $f )
1207        {
1208            $error .= "missing icon '$k' in $f \n" if !-e $f;
1209            next;
1210        }
1211    }
1212
1213# check module types for validity
1214
1215    my %types;
1216
1217# we should redo this to check for "role"
1218
1219    my %graphviz_repeaters;
1220
1221    foreach my $l ( keys %{\%module_files} ) {
1222#        print "lang $l\n";
1223        foreach my $f ( keys %{$module_files{ $l }} )
1224        {
1225            my $json = get_file_json_lang_specific( $f, $l, 1 );
1226            print "checking " . ( $l ? "for language $l " : "" ) . "module file $get_file_json_last\n";
1227           
1228            # check types for valid registry
1229            {
1230                my $x = hash_simple( $json, 'type' );
1231                print "types:\n\t" . ( join "\n\t", keys %$x ) . "\n" if keys %$x && $debug;
1232                foreach my $k ( keys %$x )
1233                {
1234                    $types{ $k }++;
1235                }
1236            }
1237            # check reserved words
1238            {
1239                my $x = hash_simple( $json, 'id' );
1240                print "id:\n\t" . ( join "\n\t", keys %$x ) . "\n" if keys %$x && $debug;
1241                $error .= valid_name( "$f \"id\"", $x );
1242            }
1243            # check for duplicate id's and listbox values
1244            {
1245                my $ref_mod = {};
1246                my $mod_info = start_json( $json, $ref_mod );
1247               
1248                my %ids;
1249
1250                do {
1251                    if ( !$$mod_info{ 'fields:id' } ) {
1252                        $error .= "Module $f has field without field id defined\n" if $$mod_info{ 'fields:type' } ne "info";
1253                    } else {
1254                        $error .= "Module $f has fields with duplicate id \"" . $$mod_info{ 'fields:id' } . "\"\n" if $ids{ $$mod_info{ 'fields:id' } }++;
1255                    }
1256                    $error .= "Module $f field " . $$mod_info{ 'fields:id' } . " is a listbox but is missing the required \"values\" tag\n" if $$mod_info{ 'fields:type' } eq 'listbox' && !$$mod_info{ 'fields:values' } && !$$mod_info{ 'fields:pull' };
1257                } while( $mod_info = next_json( $ref_mod, 'fields:id' ) );
1258            }
1259            # check repeaters & repeats
1260            {
1261                my $ref_mod = {};
1262                my $mod_info = start_json( $json, $ref_mod );
1263                my %repeater;
1264                my %repeat;
1265                my %repeattype;
1266                my $modname = $f;
1267                do {
1268                    if ( $$mod_info{ 'fields:repeater' } ||
1269                         $$mod_info{ 'fields:reverserepeater' } )
1270                    {
1271                        $repeater{ $$mod_info{ 'fields:id' } } = $$mod_info{ 'fields:type' };
1272                        if ( $$mod_info{ 'fields:type' } eq 'listbox' ) {
1273                            my @lbvalues = split '~', $$mod_info{ 'fields:values' };
1274                            $error .= "Module $f field " . $$mod_info{ 'fields:id' } . " is a listbox but the values are incorrect.  They must contain an even number of ~ separated words\n" if @lbvalues % 2;
1275                            for ( my $i = 1; $i < @lbvalues; $i += 2 ) {
1276                                my $k = $$mod_info{ 'fields:id' } . ":" . $lbvalues[ $i ];
1277                                $repeater  { $k } = $$mod_info{ 'fields:type' } . " choice " . ( 1 + ( ( $i - 1 ) / 2 ) );
1278                                $repeat    { $k } = $$mod_info{ 'fields:id' };
1279                                $repeattype{ $k } = $$mod_info{ 'fields:type' } . " choice " . ( 1 + ( ( $i - 1 ) / 2 ) );
1280                            }
1281                        }
1282                    }
1283                    if ( $$mod_info{ 'fields:repeat' } )
1284                    {
1285                        $repeat{ $$mod_info{ 'fields:id' } } = $$mod_info{ 'fields:repeat' };
1286#                        $repeat{ $$mod_info{ 'fields:id' } } =~ s/:.*$//;
1287                        $repeattype{ $$mod_info{ 'fields:id' } } = $$mod_info{ 'fields:type' };
1288                    }
1289                } while( $mod_info = next_json( $ref_mod, 'fields:id' ) );
1290               
1291                if ( $graphviz && keys %repeater )
1292                {
1293                    $modname =~ s/\.json$//;
1294                    $modname =~ s/^modules\///;
1295                    $graphviz_repeaters{$modname} = "digraph \{\n  rankdir=LR;\n  node [shape=box,style=rounded]\n  label=\"$modname repeaters\"\n";
1296                    $graphviz_cluster_no++;
1297#                foreach my $k ( keys %repeater )
1298#                {
1299#                    $graphviz_repeaters{$modname} .=  "  $k -> $repeater{$k};\n";
1300#                }
1301                }
1302
1303                if ( ($show_repeaters || $debug ) && keys %repeater )
1304                {
1305                    print "-"x60 . "\n";
1306                    print "repeaters $f\n";
1307                    print "-"x60 . "\n";
1308                    foreach my $k ( keys %repeater )
1309                    {
1310                        print "$k => $repeater{$k}\n";
1311                    }
1312                }
1313                # current repeater rules:
1314                # integer, listbox & checkbox repeaters ok at level 1
1315                # nothing can repeat to a repeated integer or listbox
1316                if ( keys %repeat )
1317                {
1318                    print "-"x30 . "\nrepeat\n" . "-"x30 . "\n" if $debug || $show_repeaters;
1319                    foreach my $k ( keys %repeat )
1320                    {
1321                        print "$k => $repeat{$k}\n" if $debug || $show_repeaters;
1322                        if ( !$repeater{ $repeat{ $k } } )
1323                        {
1324                            $error .= "Module $f field '$k' repeat on '$repeat{ $k }' : missing repeater\n";
1325                        }
1326                        if ( $repeat{ $k } eq $k )
1327                        {
1328                            $error .= "Module $f field '$k' is a self referential repeater\n";
1329                        }
1330                        my $depth = 0;
1331                        my $me = $k;
1332                        while ( $me = $repeat{ $me } )
1333                        {
1334                            if ( $depth && $me eq $k )
1335                            {
1336                                $error .= "Module $f field '$k' has parent repeater which references '$k' as a repeater creating an infinite recursive loop of repeaters\n";
1337                                last;
1338                            }
1339
1340                            $depth++;
1341                            if ( $depth > $max_repeater_depth )
1342                            {
1343                                $error .= "Module $f field '$k' exceeds maximum supported repeater depth\n";
1344                                last;
1345                            }
1346                        }
1347                    }
1348                    if ( $show_repeaters ) 
1349                    {
1350                        my $modname = $f;
1351                        $modname =~ s/\.json$//;
1352                        $modname =~ s/^modules\///;
1353
1354                        my $fo =  "output/repeaters/${modname}_repeater.txt";
1355                        mkdir_for_file( $fo );
1356                        my $fh;
1357                        if ( !open $fh, ">$fo" )
1358                        {
1359                            $error .= "show repeaters: error opening output file $fo\n";
1360                            undef $fh;
1361                        }
1362
1363                        # build a nice tree for display
1364                        print "-"x30 . "\nfull dependency\n" . "-"x30 . "\n";
1365                        foreach my $k ( keys %repeat )
1366                        {
1367                            my $depth = 0;
1368                            my $me    = $k;
1369                            my $line  = "$me\[$repeattype{$me}\]";
1370                            while ( $me = $repeat{ $me } )
1371                            {
1372                                $line .= " => $me\[$repeater{$me}\]";
1373                                $depth++;
1374                                if ( $depth > $max_repeater_depth )
1375                                {
1376                                    $error .= "Module $f field '$k' exceeds maximum supported repeater depth\n";
1377                                    last;
1378                                }
1379                            }
1380                            print "$line\n";
1381                            print $fh "$line\n" if $fh;
1382                        }
1383                        close $fh if $fh;
1384                        print "created: $fo\n" if $fh;
1385                    }
1386                    if ( $graphviz ) 
1387                    {
1388                        my %used_graph;
1389                        foreach my $k ( keys %repeat )
1390                        {
1391                            my $depth = 0;
1392                            my $me    = $k;
1393                            my $k1    = "\"$me\"";
1394                            my $lbl = $me;
1395                            $lbl =~ s/^.*://;
1396                            $graphviz_repeaters{$modname} .= "  $k1 \[label=\"$lbl\[" . $repeattype{$me} . "\]\"\]\n";
1397                            while ( $me = $repeat{ $me } )
1398                            {
1399                                my $k2  = "\"$me\"";
1400                                if ( !$used_graph{ "$k1:$k2" }++ ) 
1401                                {
1402                                    my $lbl = $me;
1403                                    $lbl =~ s/^.*://;
1404                                    $graphviz_repeaters{$modname} .= "  $k2 \[label=\"$lbl\[" . $repeater{$me} . "\]\"\]\n";
1405                                    $graphviz_repeaters{$modname} .= "  $k1 -> $k2\n";
1406                                    $depth++;
1407                                    if ( $depth > $max_repeater_depth )
1408                                    {
1409                                        $error .= "Module $f field '$k' exceeds maximum supported repeater depth\n";
1410                                        last;
1411                                    }
1412                                }
1413                                $k1 = $k2;
1414                            }
1415                        }
1416                        $graphviz_repeaters{$modname} .= "\}\n";
1417                    }
1418                }
1419                if ( $graphviz && keys %repeater )
1420                {
1421                    $graphviz_repeaters .=  "  }\n";
1422                }
1423                print "-"x30 . "\n" if keys %repeater && $show_repeaters;
1424            }
1425        }
1426    } # end module_files (per language)
1427
1428   
1429    foreach my $l ( keys %langs ) {
1430        # print "checking module to file for language $l\n";
1431        if ( !$module_to_file{ $l } ) {
1432            # print "no module_to_file for language $l\n";
1433            $module_to_file{ $l } = { %{$module_to_file{ '' }} };
1434        }
1435    }
1436
1437    # print "after fixup module_to_file:\n" . Dumper( \%module_to_file );
1438
1439    if ( $graphviz &&
1440         $get_file_json_lang_specific_used &&
1441         keys %langs > 1 ) {
1442        die "$0: -gd graphviz is currently not working with multiple languages with language specific files.  bother the developers to fix this if you need this capability\n" if $graphviz;
1443    }
1444
1445    if ( $graphviz ) 
1446    {
1447        foreach my $k ( keys %graphviz_repeaters ) {
1448            next if $k =~ /\//;
1449            my $fo = "output/graphviz/${k}_repeater.dot";
1450            mkdir_for_file( $fo );
1451            my $fh;
1452            if ( !open $fh, ">$fo" )
1453            {
1454                $error .= "graphviz: error opening output file $fo\n";
1455            } else {
1456                print $fh $graphviz_repeaters{$k};
1457                close $fh;
1458            }
1459            print "created: $fo\n";
1460        }
1461
1462# now build graphviz menu graph
1463
1464        my $ref_directives = {};
1465        my $ref_menu       = {};
1466        my %used;
1467        $rplc_directives = start_json( $directives, $ref_directives );
1468        my $title = $$rplc_directives{'title'};
1469        $rplc_menu   = start_json( $menu,   $ref_menu );
1470        my $graphviz_modules = "digraph \{\n  rankdir=LR\n  node [shape=box,style=rounded]\n  label=\"$title\"\n";
1471
1472        do 
1473        {
1474            my $menu   = $$rplc_menu{'menu:label'};
1475            my $module = $$rplc_menu{'menu:modules:label'};
1476            if ( !$used{ $menu }++ )
1477            {           
1478                $graphviz_modules .= "  \"$title\" -> \"$menu\"\n";
1479            }
1480            $graphviz_modules .= "  \"$menu\" -> \"$module\";\n";
1481
1482#            while ( my ( $k, $v ) = each %$rplc_menu )
1483#            {
1484#                print "$k => $v\n";
1485#            }
1486        } while( $rplc_menu = next_json( $ref_menu, 'menu:modules:id') );
1487
1488        $graphviz_modules .= "}\n";
1489       
1490        {
1491            my $fo = "output/graphviz/application.dot";
1492            mkdir_for_file( $fo );
1493            my $fh;
1494            if ( !open $fh, ">$fo" )
1495            {
1496                $error .= "graphviz: error opening output file $fo\n";
1497            } else {
1498                print $fh $graphviz_modules;
1499                close $fh;
1500            }
1501            print "created: $fo\n";
1502        }
1503
1504        die "$0: -gd option terminates here\n" if $graphviz;
1505    }
1506
1507    die "$0: -sr option terminates here\n" if $show_repeaters;
1508
1509
1510    foreach my $l ( keys %langs )
1511    {
1512        print "checking language types for language $l\n";
1513        foreach my $k ( keys %types )
1514        {
1515            print "checking language types for language $l type $k\n";
1516            my $b = "$gap/languages/$l/types/$k";
1517            {
1518                my $f = "$b.input";
1519                if ( !-e $f )
1520                {
1521                    $error .= "missing required file $f\n";
1522                }
1523            }
1524            {
1525                my $f = "$b.output";
1526                if ( !-e $f )
1527                {
1528                    $error .= "missing required file $f\n";
1529                }
1530            }
1531        }
1532    }
1533   
1534
1535# ------------------------------------------------------------------
1536
1537
1538    my $retval = 1;
1539    if ( $warn )
1540    {
1541        print '-'x60 . "\nWarnings:\n$warn" . '-'x60 . "\n";
1542    }
1543    if ( $error )
1544    {
1545        print '-'x60 . "\nErrors:\n$error" . '-'x60 . "\n";
1546        $retval = 0;
1547    }
1548    return $retval;
1549}
1550
1551return 1;
Note: See TracBrowser for help on using the repository browser.