#!/usr/bin/perl 

#############################################################################
# cg-eye is copyright Nick Kew, 1997
#
# You may use, copy, distribute and modify it on the same terms as Perl iself.
#
# It is offered as-is, and should be seen more as an idea than a program.
# The script is a quick, untested hack which will be fixed/improved
# when I notice bugs and omissions and when the mood takes me.  Or if
# anyone else cares to adopt the idea, with or without this script as
# starting-point, please feel free to do so.
#
# For more information, see the cg-eye webpages
#	http://www.htmlhelp.org/tools/cg-eye/
#	http://www.webthing.com/software/cg-eye.html
#
# Enjoy!
############################################################################


&cmdline;
&usage if @ARGV < 1 ;

&read_env if $opt_E ;
$QUERY_STRING = &read_form if $opt_F ;

($header, $body) = &exec_cgi($ARGV[0], $opt_M, $QUERY_STRING) ;

$headhash = &hdrcheck($header) ;

if ( $headhash->{'Content-Type'} =~ /^text\/html/i ) {
  &check_body($body) ;
}

if ( $opt_O ) {
  open (OUTPUT, ">$opt_O")
	or die "Can't write output file $opt_O" ;
  map { print OUTPUT } @$body ;
  print OUTPUT "\n";
  close OUTPUT ;
}
if ( $opt_V ) {
  open (VALIDATOR, "|$opt_V")
	or die "Can't invoke output validator $opt_V" ;
  map { print VALIDATOR } @$body ;
  print VALIDATOR "\n";
  close VALIDATOR ;
}

exit;

sub cmdline {
  use Getopt::Std ;
  getopts('vxV:O:E:F:M:') ;
}

sub usage {
print <<END;
Usage: cg-eye
	[-v]			# verbose output
	[-x]			# Extra warnings about possible problems
	[-V validator]		# Document check program (e.g. HTML validator)
	[-O output]		# File to save output document
	[-E envdata]		# Environment variables (Filename)
	[-F formdata]		# Form Data (Filename)
	[-M method]		# POST or GET (default GET)
	program_name

Environment Variables and Form Data take the form
name=value
(one name/value pair per line, no whitespace unless it's part of the value)

END
exit;
}

sub check_body {
  my $ptr = shift ;

  my @body = @$ptr ;
  map { &error($WARN, "", 'BODYHDR', $_) if /^\S+:\s*\S+/ ; } @body ;

  my $body = join('',@body) ;
  my @meta = $body =~ /(<meta.*?http-equiv.*>)/sig ;
  map { &error($WARN, "", 'META', $_) ; } @meta ;
  
  my @ssi = $body =~ /(<!--#.*?-->)/sg ;
  map { &error($WARN, "", 'SSI', $_) ; } @ssi ;
}
 
sub exec_cgi {
  my $postfile = "./.cg-eye-$$" ;
  my ( $program, $method, $QUERY_STRING ) = @_ ;
  $ENV{'REQUEST_METHOD'} = $method ;
  if ( $method eq 'GET' ) {
    $ENV{'QUERY_STRING'} = $QUERY_STRING ;
    open(CGI,"$program|") or
	&error($FATAL,"", 'OPEN', $program) ;
  } elsif ( $method eq 'POST' ) {
    $ENV{'CONTENT_LENGTH'} = length $QUERY_STRING ;
    $ENV{'CONTENT_TYPE'} = "application/x-www-form-urlencoded" ;
    $QUERY_STRING .= "\n" ;
    open(POST, ">$postfile") or
	&error($FATAL,"", 'OPEN', $program) ;
    print POST $QUERY_STRING ;
    close POST ;
    open(CGI,"$program < $postfile|") or
	&error($FATAL,"", 'OPEN', $program) ;
  }

  $line = 1 ;
  $curr = 1 ;
  $blankline = 0 ;
  while (<CGI>) {
    chomp ;
    if ( ! /./ ) {				#end of headers
      $blankline = 1 ;
      last ;
    } elsif ( /^\s/ ) {				#fold and warn
      &error($WARN, $line, 'HDRWS', $_) ;
      s/\s+// ;
      $header[$curr] .= $_ ;
    } elsif ( ! /:/ ) {				#premature end of headers
      push @body, $_ ;
      last ;
    } else {					#normal header
      $header[$curr] = $_ ;
      $curr++ ;
    }
    $line++ ;
  }
  $blankline || &error($ERROR, $line, 'NOBLANK') ;

  my @body = (<CGI>) ;
  close CGI ;
  unlink $postfile if $method eq 'POST' ;

  return ( \@header, \@body ) ;
}
sub hdrcheck {
  my $hptr = shift ;
  my $name,$val;
  my @hlines = @$hptr ;
  my %header ;
  my $line = 0 ;
  for (@hlines) {
    $line++ ;
    $_ or next;
    ($name, $val) = split(/\:\s*/,$_,2) ;
    $name =~ s/(\w)(\w*)/\U$1\E\L$2\E/g ;
    if ( ($name !~ /./) || ($val !~ /./) )
	{ &error($ERROR, $line, 'PARTHDR', $_) ; }
    if ( $header{$name} != "" )
	{ &error($WARN, $line, 'DUPHDR', $_) ; }
    $header{$name} = $val ;
    if ( $name eq "Location" ) {
      unless ( $val =~ /^\w+:\/\// ) {
	$status = 'RELLOC' ;
	if ( $#hlines > 1 ) {
	  &error($ERROR, $line, 'RELLOC2', $_) ;
	}
      }
    }
  }
  if ( $status eq '' ) {
    if ( defined $header{'Status'} ) {
      $status = 'STATUS' ;
    } elsif ( defined $header{'Location'} ) {
      $status = 'LOCATION' ;
    } elsif ( defined $header{'Content-Type'} ) {
      $status = 'CTYPE' ;
    }
  }
  if ( $status eq '' ) {
    &error($ERROR, "", 'NOHDR') ;
  } else {
    &error($INFO, "", $status) ;
    if ( ! defined $header{'Content-Type'} ) {
      &error($WARN, "", 'NODOC') unless $status eq 'RELLOC' ;
    }
    if ( ( $status eq 'STATUS' ) && ( defined $header{'Location'} ) ) {
      unless ( $header{'Location'} =~ /^30[12]/ ) {
        &error($ERROR, "", 'STLOC') ;
      }
    }
  }
  if ( $opt_x ) {
    &error($WARN, "", 'PRAGMA') if $header{'Pragma'} ;
    &error($WARN, "", 'COOKIE') if $header{'Set-Cookie'} ;
    &error($WARN, "", 'WINDOW') if $header{'Window-Target'} ;
    &error($WARN, "", 'CONNECTION') unless $header{'Connection'} ;
    &error($WARN, "", 'LENGTH') unless $header{'Content-Length'} ;
    &error($WARN, "", 'OCTET')
	if $header{'Content-Type'} eq 'application/octet-stream' ;
  }
  \%header ;
}
sub error {
  my ( $severity, $linenum, $msg, $line ) = @_ ;

  print $severity ;
  print ": at line $linenum" if $linenum ;
  print "\n", $line if $line ;
  print "\n", $brief{$msg}, "\n" ;
  print "\n", $full{$msg}, "\n" if $opt_v ;
  print "\n" ;

  exit if $severity =~ /FATAL/ ;
}
sub read_env {
  open(ENVDATA, "<$opt_E")
	|| die "Can't open environment data file $opt_E" ;
  while (<ENVDATA>) {
    chomp ;
    s/(.*?)=(.*)/\U$1\E=$2/ ;
    split('=',$_,2) ;
    $ENV{$1} = $2 ;
  }
  close ENVDATA ;
}
sub read_form {
  use URI::Escape ;
  my @query ;
  open(FORM, "<$opt_F")
	|| die "Can't open form data file $opt_F" ;
  while (<FORM>) {
    chomp ;
    push @query , &uri_escape($_) ;
  }
  close FORM ;
  return join ('&', @query) ;
}


BEGIN {
  $INFO = "INFORMATONAL" ;
  $WARN = "WARNING" ;
  $ERROR = "ERROR" ;
  $FATAL = "FATAL ERROR" ;

#Error/warning messages
  %brief = (
	'BODYHDR' =>	"Line with HTTP Header syntax found in HTML output" ,
	'META'	=>	"<META HTTP-EQUIV> found in HTML output" ,
	'SSI'	=>	"SSI found in HTML output" ,
	'OPEN'	=>	"Failed to run program" ,
	'HDRWS' =>	"Header continued from previous line" ,
	'NOHDR' =>	"No CGI Headers" ,
	'NOBLANK' =>	"No blank line after headers" ,
	'NODATA' =>	"No data after headers" ,
	'PARTHDR' =>	"Incomplete header line" ,
	'DUPHDR' =>	"Duplicate Header" ,
	'RELLOC2' =>	"Internal Redirect with other headers" ,
	'NODOC'	=>	"No Document Body" ,
	'STLOC'	=>	"Status header is incompatible with Location" ,
	'PRAGMA' =>	"Pragma header found" ,
	'COOKIE' =>	"Set-Cookie is nonstandard" ,
	'WINDOW' =>	"Window-Target is nonstandard" ,
	'CONNECTION' =>	"No Connection header" ,
	'LENGTH' =>	"No Content-Length header" ,
	'OCTET'	=>	"MIME type was application/octet-stream" ,
	'RELLOC' =>	"Redirecting internally" ,
	'STATUS' =>	"Setting own HTTP status code" ,
	'LOCATION' =>	"Redirecting the user agent to another URL" ,
	'CTYPE'	=>	"Returning status 200 with a document" ,
  ) ;

#Extra output for Verbose mode
  %full = (
	'BODYHDR' =>
qq(HTTP Headers in a document body will be displayed by a browser.\
If you want other behaviour, it has to be in the HTTP headers.).
	'DUPHDR' =>
qq(Undefined behaviour) ,
	'NOBLANK' =>
qq(The HTTP Headers must always be followed by a blank line) ,
	'META'	=>
qq(You are better off using real HTTP headers than META in CGI output.) ,
	'SSI'	=>
qq(CGI output is not parsed (except as a possible 'extension'), and if\
parsed opens some serious security risks.) ,
	'HDRWS'	=>
qq(Continuation headers are allowed, but may not be universally supported\
(and did you intend it?)) ,
	'NOHDR' =>
qq(Your program must output at least one of the 'special' CGI Headers\
(Content-Type, Location, or Status), or you will get an error such as\
"The application misbehaved ..." or "Premature end of script headers") ,
	'NODATA' =>
qq(Document headers must be followed by a blank line, then (normally)\
document data, or you will get the 'Document contains no data' error) ,
	'RELLOC' =>
qq(The program is instructing the SERVER to process the request AS IF a\
different URL had been specified) ,
	'STATUS' =>
qq(The program specified a custom HTTP response code.  This is normally\
necessary when neither Content-Type nor Location is appropriate) ,
	'LOCATION' =>
qq(The program directed the BROWSER to another URL) ,
	'CTYPE' =>
qq(The program returned a document to the browser) ,
	'RELLOC2' =>
qq(The Location header with a relative URL will not generate an HTTP\
Response, so other headers will not work with it) ,
	'NODOC'	=>
qq(Although no document data is required with Status or Location, it is \
usually good practice to send something for the benefit of broken browsers) ,
	'STLOC'	=>
qq(Redirection (the Location Header) implies Status 301 or 302.  There is\
usually no need to print any Status header with a Location) ,
	'PRAGMA' =>
qq(Pragma is obsolete, and does not work as many authors expect with
browsers.  Use Cache-Control instead.) ,
	'CONNECTION' =>
qq(The header "Connection: close" can be a solution to browsers that
refuse to finish loading even when your script has completed).
	'LENGTH' =>
qq(A Content-Length header can be a solution to browsers that
refuse to finish loading even when your script has completed).
	'OCTET'	=>
qq(application/octet-stream is a valid MIME type, but is rarely the
correct choice) ,
) ;
  print <<INTRO;
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+	  cg-eye: CGI test harness (prototype), Nick Kew, 1997		+
+	   This is an experimental script: do not rely on it		+
+	     Comments and suggestions to nick\@webthing.com		+
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

INTRO

  $opt_M = 'GET' ;	#default METHOD
  map { undef $ENV{$_} ; } keys %ENV ;
}