#!/usr/bin/perl -w
# 
# check_perl
# 
# Do syntax checks on Perl programs.  At present just calls perl -c.
# 
# Usage:
# 
# check_perl [flags] files...
# 
# (if no files given, reads standard input.  '-' is stdin also.)  
# Flags given are passed to perl.
# 
# WARNING: because in 'syntax checking' a program, Perl executes the
# BEGIN and END blocks, you should not check any program you would not
# be happy to run.  If you don't trust the program, don't check it
# with this script or with perl.
# 
# FIXME: this is all completely broken
#  
# -- Ed Avis, epa98@doc.ic.ac.uk, 1999-10-20
# 

use strict;
use diagnostics;

@ARGV = ('-') if not @ARGV;

# Split @ARGV into flags and files.
my @flags = ();
my @files = ();
my $doneflags = 0;
foreach (@ARGV) {
    if (/^-/ and not $doneflags) {
	push @flags, $_;
    }
    else {
	$doneflags = 1;
	push @files, $_;
    }
}
my $flags = join(' ', @flags);

foreach my $arg (@files) {
#    print "perl -c $flags $arg 2>&1 |\n";
    open(P, "perl -c $flags $arg 2>&1 |");
    chomp(my @lines = <P>);
    @lines = join_lines(@lines);

    if (@lines == 0) {
	warn "$0: $arg: perl said nothing at all";
    }
    elsif (@lines == 1) {
	$_ = $lines[0];
	unless (/syntax OK$/) {
	    print "$_\n";
	}
    }
    else {
	$_ = pop @lines;
	unless (/had compilation errors\.$/
		or /syntax OK$/) {
	    print "$_\n";
	}

	my @results = ();
	foreach (@lines) {
	    if (/syntax OK$/) {
		warn "$0: $arg: perl said 'syntax OK', but...";
	    }
	    elsif (/had compilation errors\.$/) {
		warn "$0: $arg: perl said 'compilation errors' more than once";
	    }
	    elsif (/^(.+) at (.+) line (\d+).$/) {
		push @results, "$2:$3: $1";
	    }
	    elsif (/^(.+) at (.+) line (\d+), near (.+?)$/) {
		push @results, "$2:$3: $1, near $4";
	    }
	    elsif (/^(.+) at (.+) line (\d+), near (.+?) \((.+)\)$/) {
		push @results, "$2:$3: $1, near $4 ($5)";
	    }
	    else {
		if (@results) {
		    push @results, ((pop @results) . ' ' . $_);
		}
		else {
		    push @results, $_;
		}
	    }
	}

	print join("\n", @results), "\n";
    }
}


sub join_lines(@) {
    return () if @_ == 0;
    return @_ if @_ == 1;
    my ($first, $second, @rest) = @_;

    if ($second =~ s/^\s+/ /) {
	return join_lines($first . $second, @rest);
    }
    else {
	return ($first, join_lines($second, @rest));
    }
}