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