1#!/usr/bin/perl -- -*-cperl-*-
2
3## Check all the perl and calc blocks embedded in ITL tags in one or more files
4## Greg Sabino Mullane <greg@endpoint.com>
5
6use strict;
7use warnings;
8use Getopt::Long;
9
10our $VERSION = '1.1.2';
11
12@ARGV or show_help();
13
14my $opt= {
15          verbose      => 0,
16          keeptempfile => 0,
17          quiet        => 0,
18          };
19
20GetOptions ## no critic (ProhibitCallsToUndeclaredSubs)
21    ($opt,
22     'verbose+',
23     'help',
24     'keeptempfile',
25     'quiet'
26     );
27
28$opt->{help} and show_help();
29
30sub show_help {
31
32    print qq{
33Usage: $0 [Options] filename(s)
34Description: Checks that perl and calc blocks in ITL code are valid
35Options:
36  --help          Show this help message
37  --verbose       Verbose output
38  --keeptempfile  Do not erase the temporary file(s) created
39  --quiet         Show failing files only
40
41};
42    exit;
43}
44
45my %seenit;
46for my $file (@ARGV) {
47    next if $seenit{$file}++;
48    if (-d $file) {
49        $opt->{verbose} and print qq{** Skipping directory "$file"\n};
50        next;
51    }
52    if (! -f $file) {
53        $opt->{verbose} and print qq{** Skipping "$file"\n};
54        next;
55    }
56    if ($file =~ /\.tmp$/o) {
57        $opt->{verbose} and print qq{** Skipping temp file "$file"\n};
58        next;
59    }
60    check_perl_itl($file);
61}
62
63exit;
64
65sub check_perl_itl {
66
67    my $file = shift;
68    open my $rh, '<', $file or die qq{Could not open "$file": $!\n};
69
70    my $tempfile = "$file.perltest.tmp";
71    open my $wh, '>', $tempfile or die qq{Could not write "$tempfile": $!\n};
72    $opt->{verbose} >= 2 and print qq{** Wrote "$tempfile"\n};
73    my $top = qq{#!perl
74
75## Temporary file created by extracting perl and calc blocks from the file "$file"
76
77use strict;
78use warnings;
79};
80$top .= q{use vars qw/
81$CGI
82$CGI_array
83$Carts
84$Config
85$DbSearch
86$Document
87$Scratch
88$Session
89$Tag
90$TextSearch
91$Tmp
92$Values
93$Variable
94%Sql %Db
95/;
96
97};
98
99    print $wh $top;
100    my $templines = $top =~ tr/\n/\n/;
101
102    my $inperl = 0;
103    my $subnum = 0;
104    my %mapline;
105    my $tagstart = qr{\s*(?:perl|calcn?)\s*};
106    my $tagend   = qr{\[\s*/\s*(?:perl|calcn?)\s*\]};
107    my $subtext  = '';
108
109    while (<$rh>) {
110
111        if (!$inperl) {
112            next unless m{\[$tagstart\s*([^\]]*)\](.*?)($tagend)?$};
113            my ($attr,$extra,$closetag) = ($1,$2,$3);
114            $inperl = 1;
115            $subnum++;
116            print $wh "sub perl_itl_$subnum {\n";
117            $templines++;
118            if (length $extra and $extra =~ /\S/) {
119                $subtext .= "$extra\n";
120                $mapline{++$templines} = $.;
121            }
122            if ($closetag) {
123                print $wh itl_escape($subtext);
124                $subtext = '';
125                print $wh "\n} ## end of perl_itl_$subnum\n\n";
126                $templines += 3;
127                $inperl = 0;
128            }
129            next;
130        }
131
132        if (m{(.*)$tagend}o) {
133            my $pre = $1;
134            $subtext .= $1;
135            printf $wh "%s\n} ## end of perl_itl_$subnum\n\n", itl_escape($subtext);
136            $subtext = '';
137            $templines += 3;
138            $inperl = 0;
139            next;
140        }
141
142        $subtext .= $_;
143        $mapline{++$templines} = $.;
144    }
145	close $wh or die qq{Could not close "$tempfile": $!\n};
146
147    if ($opt->{verbose} >= 2) {
148        print "** Subroutines found: $subnum\n";
149        print "** Lines in original file: $.\n";
150        print "** Lines in temp file: $templines\n";
151    }
152
153    close $rh or die qq{Could not close "$file": $!\n};
154
155    my $errors = qx{perl -c $tempfile 2>&1};
156    unlink $tempfile unless $opt->{keeptempfile};
157
158    if ($errors =~ /$tempfile syntax OK$/) {
159        print qq{File "$file" had no Perl problems\n} unless $opt->{quiet};
160        return;
161    }
162
163    print qq{File "$file" has the following Perl problems:\n};
164    for my $line (split /\n/ => $errors) {
165        next if $line =~ /had compilation errors/o;
166        chomp $line;
167        $line =~ s/at $tempfile line (\d+)\.?/exists $mapline{$1} ? "(line $mapline{$1})" : "(original line $1)"/e;
168        print "--> $line\n";
169    }
170
171    return;
172}
173
174
175sub itl_escape {
176    my $text = shift;
177
178    ## Filter out pragmas
179    $text =~ s{\[pragma(.*?)\]}{ }gso;
180
181    ## Filter out macros
182    my $AZ = qr{[A-Za-z0-9]};
183    $text =~ s/\@\@$AZ\w+$AZ\@\@/11111/go;
184    $text =~ s/\@_$AZ\w+${AZ}_\@/22222/go;
185    $text =~ s/__$AZ\w*?${AZ}__/33333/go;
186
187    ## Filter out comment tags
188    $text =~ s{\[comment\].*?\[/comment\]}{ }gs;
189
190    return $text;
191}
192