#!/usr/bin/perl -- -*-cperl-*-

## Check all the perl and calc blocks embedded in ITL tags in one or more files
## Greg Sabino Mullane <greg@endpoint.com>

use strict;
use warnings;
use Getopt::Long;

our $VERSION = '1.1.2';

@ARGV or show_help();

my $opt= {
          verbose      => 0,
          keeptempfile => 0,
          quiet        => 0,
          };

GetOptions ## no critic (ProhibitCallsToUndeclaredSubs)
    ($opt,
     'verbose+',
     'help',
     'keeptempfile',
     'quiet'
     );

$opt->{help} and show_help();

sub show_help {

    print qq{
Usage: $0 [Options] filename(s)
Description: Checks that perl and calc blocks in ITL code are valid
Options:
  --help          Show this help message
  --verbose       Verbose output
  --keeptempfile  Do not erase the temporary file(s) created
  --quiet         Show failing files only

};
    exit;
}

my %seenit;
for my $file (@ARGV) {
    next if $seenit{$file}++;
    if (-d $file) {
        $opt->{verbose} and print qq{** Skipping directory "$file"\n};
        next;
    }
    if (! -f $file) {
        $opt->{verbose} and print qq{** Skipping "$file"\n};
        next;
    }
    if ($file =~ /\.tmp$/o) {
        $opt->{verbose} and print qq{** Skipping temp file "$file"\n};
        next;
    }
    check_perl_itl($file);
}

exit;

sub check_perl_itl {

    my $file = shift;
    open my $rh, '<', $file or die qq{Could not open "$file": $!\n};

    my $tempfile = "$file.perltest.tmp";
    open my $wh, '>', $tempfile or die qq{Could not write "$tempfile": $!\n};
    $opt->{verbose} >= 2 and print qq{** Wrote "$tempfile"\n};
    my $top = qq{#!perl

## Temporary file created by extracting perl and calc blocks from the file "$file"

use strict;
use warnings;
};
$top .= q{use vars qw/
$CGI
$CGI_array
$Carts
$Config
$DbSearch
$Document
$Scratch
$Session
$Tag
$TextSearch
$Tmp
$Values
$Variable
%Sql %Db
/;

};

    print $wh $top;
    my $templines = $top =~ tr/\n/\n/;

    my $inperl = 0;
    my $subnum = 0;
    my %mapline;
    my $tagstart = qr{\s*(?:perl|calcn?)\s*};
    my $tagend   = qr{\[\s*/\s*(?:perl|calcn?)\s*\]};
    my $subtext  = '';

    while (<$rh>) {

        if (!$inperl) {
            next unless m{\[$tagstart\s*([^\]]*)\](.*?)($tagend)?$};
            my ($attr,$extra,$closetag) = ($1,$2,$3);
            $inperl = 1;
            $subnum++;
            print $wh "sub perl_itl_$subnum {\n";
            $templines++;
            if (length $extra and $extra =~ /\S/) {
                $subtext .= "$extra\n";
                $mapline{++$templines} = $.;
            }
            if ($closetag) {
                print $wh itl_escape($subtext);
                $subtext = '';
                print $wh "\n} ## end of perl_itl_$subnum\n\n";
                $templines += 3;
                $inperl = 0;
            }
            next;
        }

        if (m{(.*)$tagend}o) {
            my $pre = $1;
            $subtext .= $1;
            printf $wh "%s\n} ## end of perl_itl_$subnum\n\n", itl_escape($subtext);
            $subtext = '';
            $templines += 3;
            $inperl = 0;
            next;
        }

        $subtext .= $_;
        $mapline{++$templines} = $.;
    }
	close $wh or die qq{Could not close "$tempfile": $!\n};

    if ($opt->{verbose} >= 2) {
        print "** Subroutines found: $subnum\n";
        print "** Lines in original file: $.\n";
        print "** Lines in temp file: $templines\n";
    }

    close $rh or die qq{Could not close "$file": $!\n};

    my $errors = qx{perl -c $tempfile 2>&1};
    unlink $tempfile unless $opt->{keeptempfile};

    if ($errors =~ /$tempfile syntax OK$/) {
        print qq{File "$file" had no Perl problems\n} unless $opt->{quiet};
        return;
    }

    print qq{File "$file" has the following Perl problems:\n};
    for my $line (split /\n/ => $errors) {
        next if $line =~ /had compilation errors/o;
        chomp $line;
        $line =~ s/at $tempfile line (\d+)\.?/exists $mapline{$1} ? "(line $mapline{$1})" : "(original line $1)"/e;
        print "--> $line\n";
    }

    return;
}


sub itl_escape {
    my $text = shift;

    ## Filter out pragmas
    $text =~ s{\[pragma(.*?)\]}{ }gso;

    ## Filter out macros
    my $AZ = qr{[A-Za-z0-9]};
    $text =~ s/\@\@$AZ\w+$AZ\@\@/11111/go;
    $text =~ s/\@_$AZ\w+${AZ}_\@/22222/go;
    $text =~ s/__$AZ\w*?${AZ}__/33333/go;

    ## Filter out comment tags
    $text =~ s{\[comment\].*?\[/comment\]}{ }gs;

    return $text;
}
