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

Last change on this file since 936 was 936, checked in by ehb, 6 years ago

alpha copy of genapp

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