#!/usr/bin/env perl
#/scripts 775
# CGITRAP (1998 Eric Boesch, ericboesch@gmail.com), from
#########################################################################
#
# CGITAP Copyright 1996 Charles D. Johnson, ScendTek Internet Corp.
# Permission granted to use and modify this application so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the application.
#
# Many thanks to Steven Brenner for his ReadParse procedure!
# ReadParse was my first introduction to the CGI interface and
# parsing FORM POST Data.
#
# CGITAP - CGI Script Analysis and Debugging Utility
#
#########################################################################
# 
# CGITRAP additions:  CGI header parsing; timing info; target script may
# come first; can work invisibly unless apparent errors occur; works with
# my Netscape server; command-line debugging within replicated CGI
# environment (see debug_call); stdout separated from stderr.  Tested on
# Perl 5.00[345], httpd Netscape|Apache, OS solaris|linux.
# Comments, extensions, and bug fixes welcome.
#
# Invocation same as cgitap's (see http://scendtek.com/cgitap).
#
# Configuration section:

use strict;
use warnings;
require 5;

my ($quiet_if_ok, $log_fn, $debug_call, $execute, $time_info, $wrapper_name,
    $tmp_dir, $paranoid, $post_stdin, $time0, $setuid);

# Edit the value of $tmp_dir below.  All files generated by cgitrap
# will be placed in that directory.

$tmp_dir = "/tmp";

# To do command-line debugging of non-Perl programs, change $debug_call and
# $post_stdin.  See the HTML documentation for more details on these.

$debug_call	= 'perl -d';
$post_stdin	= 1;

# Set $quiet_if_ok if you do not want to see _any_ cgitap
# output unless an error is detected while running the script.

$quiet_if_ok = 1;

# Set $log_fn if you want to record all of the URLs processed.
# POST form data will be converted to GET format in the URL.

# $log_fn	= 'html.log';

# If you want to debug the page offline, and you DON'T want to run the page
# online because of unwanted side effects, then set $execute to false.

$execute = 1;

# If you have Time::HiRes, uncomment the following line:
# use Time::HiRes qw(time);

# It's probably reasonably safe to use setuid on this script, because
# that usually means REDUCING rights to that of the web user. However,
# setuid scripts are disabled on many OSes and inherently insecure on
# a few others (though those are probably obsolete).
$setuid = 0; # Change to 1 to enable

# If cgitrap rejects your valid header, go to the section with the
# "OK header line" comment and add your header to the OK list.  If cgitrap
# accepts an invalid header, you might not get any kind of useful output
# online (although the myscript_dbg.pl file will be usable).  Temporarily
# setting $paranoid to 1 may help; the down side is that your CGI and HTML
# header sections will be ignored whether they're valid or not.
# (You can also create a backup copy of cgitrap, "cgitrap.bak", with
# $paranoid preset to 1.  That will also allow you to debug modifications to
# cgitrap itself using URL http://myhost/cgi-bin/cgitrap.bak/cgitrap/myscript.)

BEGIN {
  $paranoid = 0;
  $time_info		= 1;    # Show running times?
  $wrapper_name	= "cgitrap";    # The start of this script's name
  $time0 = time	if $time_info;
}

# This program removes itself from the SCRIPT_NAME environment variable.
# Consequently, programs that generate URLs from SCRIPT_NAME may generate
# links to non-debugged URLs.  To make sure that debugging-enabled URLs
# always point to other debugging-enabled URLs, you may want to alter those
# programs so that they check for the existence of REAL_SCRIPT_NAME.  (If
# you use the symbolic-link invocation method, this is unnecessary.)
#
# End of configuration section.
#########################################################################

my $hide_me     = 1;    # Remove CGITRAP from CGI env. variables?
my $show_debug	= $paranoid || !$quiet_if_ok;
my @time	= ();

$tmp_dir = ''	if !defined($tmp_dir);
$tmp_dir .= '/'	if $tmp_dir ne '';

push @time, [$time0, '']	if $time_info; # Start time.

my $content_text = "Content-type:text/html\n";
my $head = $content_text;
my $body = "\n";
my $this;

$body .= "<I>CGITRAP</I> - CGI Script Analysis and Debugging Utility";

$0 =~ m:([^/]+)$:; # separate path and this script's name
$this = $1; # this script name

my ($prog_exe, $prog);

if (index($this, $wrapper_name) >= 0) {
  # translate some of the environment because wrapper is in the path
  my $path = $ENV{ PATH_INFO };
  unless ($path) {
    print "$head$body";
    print "<H3>CGITRAP must have a target CGI script specified:</H3>\n";
    print "<H4>Example: http://yourserver.com/cgi-bin/cgitrap/script</H4>\n";
    exit(0);
  }
  $path =~ m:/([^/]+)(.*):;
  $prog = $1;
  $prog_exe = $prog;

  if ($hide_me) {
    $ENV{ REAL_SCRIPT_NAME } = "$ENV{ SCRIPT_NAME }/$prog";
    $ENV{ PATH_INFO } = $2;	# remove cgi-script program name from path
    
    $ENV{ SCRIPT_NAME } =~ s:[^/]+$:$prog:; # adjust the script name variable
    if (defined($ENV{ SCRIPT_FILENAME })) {
      # adjust the script filename variable
      $ENV{ SCRIPT_FILENAME } =~ s/[^\/]+$/$prog/;
    }
    $ENV{ PATH_TRANSLATED } =~ s/\/$prog//; # remove script name from path
  }
}
else {
  # cgitrap is not in the path, we are using the symbolic link
  # method of execution
  $prog = "$this";
  $prog_exe = "${this}.tap";
}

$body .= <<EOF;
<HR>
<H3>General Diagnostics</H3>
<pre>
CGI Script = $prog (via $prog_exe)
EOF

my $prog_path;

if ($ENV{ SERVER_SOFTWARE } =~ /cern/i) {
  $prog_path = $ENV{ SCRIPT_NAME }; # cern uses SCRIPT_NAME
  $prog_path =~ s/[^\/]+$/$prog_exe/;
} elsif (defined($ENV{ SCRIPT_FILENAME })) {
  $prog_path = $ENV{ SCRIPT_FILENAME };
  $prog_path =~ s/[^\/]+$/$prog_exe/;
} else {
  $prog_path = "./$prog_exe";
}

if (-e $prog_path) {
  unless (-x _) {
    $body .= "%% WARNING %% - Designated script: $prog_exe does not "
      . "have execute permissions\n";
    $show_debug = 1;
  }
  if (-u _ || -g _ || -k _) {
    $body .= "%% WARNING %% - Designated script: $prog_exe has setuid, "
      . "setgid and/or sticky bit set\n";
    $show_debug = 1;
  }
} else {
  $body .= "%% WARNING %% - Target script: $prog_exe ($prog_path) does not " .
      "exist\n";
  $show_debug = 1;
}

$body .= "\n\n</pre>\n";

# Dump the environment variables

$body .= "<HR>
<H3>CGI Environment</H3>
<pre>
";

my ($var);

foreach $var (sort keys(%ENV)) {
  $body .= "$var = $ENV{$var}\n";
}

$body .= "\n\n</pre>\n";

my ($form_data, $form_data_hash_r) = (ReadParse())[0,2];
my %form_data = %$form_data_hash_r;
my $have_post_data = uc($ENV{ REQUEST_METHOD } || '') eq 'POST' ?
  $post_stdin ? 2 : 1 : 0;
# 0: There is no post data.
# 1: In debug call, don't redirect stdin to the post data.
# 2: In debug call, redirect stdin to the post data.

$ENV{ POST_DATA } = $form_data if $have_post_data;

CREATE_LOG:
if (defined($log_fn)) {
  $log_fn = "$tmp_dir$log_fn"	if substr($log_fn,0,1) ne '/';
  open LOG, ">>$log_fn"
    or do {
	$body .= "<hr>WARNING: Could not append log script "
	  . dir_full_name($log_fn) . " ($!).\n";
	$show_debug = 1;
	last CREATE_LOG;
      };
  print LOG "http://$ENV{ SERVER_NAME }$ENV{ SCRIPT_NAME }$ENV{ PATH_INFO }" .
    ($form_data ? "?$form_data" : "") . "\n";
  close LOG;
}

CREATE_DEBUG:
{
  if ($debug_call) {	       # Create the debugging wrapper program.
    my $prog_no_ext = $prog;
    $prog_no_ext =~ s/\.pl$//;
    my $debug_fn = "${prog_no_ext}_dbg.pl";

    $ENV{ PATH } =~ s/^://;

    my $filename = "$tmp_dir$debug_fn";
    # unlink $filename;

    open(DEBUG, ">$filename")
      or do {
	my $dfn = dir_full_name($tmp_dir);
	$body .= <<EOF;
<hr>WARNING: Could not write debug script $dfn$debug_fn ($!).
(Make sure that user ID $> has write permission for $dfn.)
EOF
	$show_debug = 1;
	last CREATE_DEBUG;
      };

    print DEBUG <<EOF;
#!/usr/bin/env perl
\%ENV =
 (
EOF

    while (my ($var, $val) = each %ENV) {
      print DEBUG "  $var => \"\Q$val\E\",\n";
    }

    print DEBUG <<EOF;
 );
exec('@{[$have_post_data == 2 ? 'echo $POST_DATA | ' : '']
       }$debug_call $prog_path');
EOF

    close DEBUG;

    chmod(($setuid ? 04755 : 0755), $filename);
  }
}

$body .= <<EOF;
<HR><PRE>
<H3>$ENV{'REQUEST_METHOD'} Form Data</H3>
EOF

foreach $var (keys %form_data) {
  $body .= "$var = $form_data{ $var }\n";
}
$body .= "\n\n</pre>\n";

if (!$execute) {
  print <<EOF;
$head

<h2>Dummy Page</h2>

<P>Execution disabled.

<P>\$execute set to false in cgitrap.
<HR>
$body
EOF

  exit;
}

unless (-e $prog_path) {
  print <<EOF;
$head$body
<H3>Exiting because target script is not present!</H3>
EOF
  
  exit;
}

my $have_stderr	= 1;
close STDERR;
open STDERR, ">${tmp_dir}stderr.tmp"
  or do {
    $body .= "<hr>WARNING: Could not write file " . dir_full_name() .
      "stderr.tmp ($!).\n";
    $show_debug = 1;
    $have_stderr = 0;
  }; 

my $syscall = ($have_post_data ? 'echo $POST_DATA | ' : '') . "$prog_path";

push(@time, [time, "Setup"]) if $time_info;
my @get = `$syscall`;
push(@time, [time, "Running"]) if $time_info;

close STDERR;

delete($ENV{ POST_DATA });

my ($err_stat, $err_msg) = ($?, $!);

my $stderr;
if ($have_stderr) {
  open STDERR_IN, "<${tmp_dir}stderr.tmp";
  if (read STDERR_IN, $stderr, 100000) {
    $show_debug = 1;
    $body .= "<HR>STDERR:\n" . html_quote($stderr);
  }
  close STDERR_IN;
}

if ($err_stat) {
  $body .= <<EOF;
<HR>
Exit value: @{[$err_stat >> 8]}<BR>
System return code: @{[$err_stat & 0xff]}<BR>
Error message: $err_msg<BR>
EOF
}

my $have_cookie = 0;

if (!@get) {
  print "$head$body\nCould not start $prog to execute (or no output)!\n";
  exit;
}

if ($paranoid) {
  print $content_text;
} else {			# Check header syntax
  # Print every valid CGI header line, and ignore all others.
  # If $have_type is still false after the entire header has been read,
  # add a "content-type: text" line.

  # Do I have a content-type header or acceptable substitute?
  my $have_type;
  my $header_lines = 0;
  
  foreach (@get) {
    $header_lines++;
    if (/^content-type:/i) {
      if (!/^content-type:[ \t]*text\/html\b/i) {
	if ($show_debug) {
	  $body .= "<h2>Suppressing $_ output because of errors.</h2>\n";
	  $_ = $content_text;
	} else {
	  # Print non-HTML content verbatim if error-free.
	  splice @get, 0, $header_lines - 1;
	  print @get;
	  exit;
	}
      }
      $have_type = 1;
    } elsif (/^location:/i || /^uri:/i) {
      # Acceptable substitutes for a content-type header.
      $have_type = 1;
    } elsif (/^expires:/i || /^date:/i || /^set-cookie:/i || m:^HTTP/:i ||
	     /^status:/i || /^pragma:/i || /^content-disposition:/i ||
	     /^refresh:/i
	    ) {
    }				# OK header line.
    elsif ($_ ne "\n" && $_ ne "\r\n") {	# Bad header line -- ignore.
      $body .= "<hr>Unknown CGI header ignored-- $_";
      $show_debug = 1;
      next;
    } else {
      last;
    }
    print;
  }
  
  if (!$have_type) {
    print $content_text;
    $show_debug = 1;
    $body .= "<hr>CGI header does not specify content-type or URI.\n";
  }
}

print "\n";

# End of CGI header section.

$show_debug ||= $err_stat;

if (!$show_debug) {
  # Suppress debugging output
  output_array(\@get);
  print_time();
  exit;
}

$body .= <<EOF;
<HR>
<H3>CGI Script Output for $prog (via $prog_exe)</H3>
EOF

$body .= html_quote(join('',@get)) . "<br>\n";

if ($paranoid) {
  print $body, <<EOF;
<HR><H3>CGITAP Complete, Resulting HTML document follows...</H3><HR><BR><BR><BR>
EOF

}

output_array(\@get);

if (!$paranoid) {
  print "<HR><H3>HTML document complete, CGITAP output follows...</H3>",
      "<HR><BR><BR><BR>$body"; # Print CGITAP's content
}

push(@time, [time, "Cleanup"]) if $time_info;

print_time();

sub print_time {
  return unless $time_info;

  my $old_time = ${shift @time}[0];
  foreach (@time) {
    my ($new_time, $name) = @$_;
    printf "$name: %.2f seconds\n", $new_time - $old_time;
    $old_time = $new_time;
  }
}


####################################################################
# Copyright 1994 Steven E. Brenner  
# Unpublished work.
# Permission granted to use and modify this library so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the library.
#
# Thanks are due to many people for reporting bugs and suggestions
# especially Meng Weng Wong, Maki Watanabe, Bo Frese Rasmussen,
# Andrew Dalke, Mark-Jason Dominus and Dave Dittrich.
#
# see http://www.seas.upenn.edu/~mengwong/forms/   or
#     http://www.bio.cam.ac.uk/web/                for more information
#
# ReadParse was modified by ScendTek Internet Corp.; 7/3/95
#
# ReadParse
# Reads in GET or POST data, converts it to unescaped text, and puts
# one key=value in each member of the list "@in"
# Also creates key/value pairs in %in, using '\0' to separate multiple
# selections
#
# Removed format flexibility to obtain adherence to STRICT standards -- emb.
#
# Returns three references:  a scalar string, an array, and a hash.

sub ReadParse {
  my $in;
  my @in = ();
  my %in = ();

  my ($i, $loc, $key, $val);

  # Read in text
  if ($ENV{'REQUEST_METHOD'} eq "GET") {
    $in = $ENV{'QUERY_STRING'};
  } elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
    read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
  }

  $in = '' if !defined($in);

  @in = split(/&/,$in);

  my $var;
  foreach $var (@in) {
    # Convert plus's to spaces
    $var =~ s/\+/ /g;
    # Convert %XX from hex numbers to alphanumeric (moved: ScendTek; 7/3/95)
    $var =~ s/%(..)/pack("c",hex($1))/ge;

    # Split into key and value.  
    ($key, $val) = split(/=/,$var,2); # splits on the first =.

    # Convert %XX from hex numbers to alphanumeric
    #$key =~ s/%(..)/pack("c",hex($1))/ge;
    #$val =~ s/%(..)/pack("c",hex($1))/ge;

    # Associate key and value
    $in{$key} .= " :: " if (defined($in{$key})); # :: is the multiple separator (ScendTek; 7/3/95)
    $in{$key} .= $val;

  }

  # return 1; # just for fun
  return ($in, \@in, \%in);
}

# Script's content.
# A fallible attempt is made to remove </html> and </body>,
# so we can see CGITRAP's output too.

sub output_array {
  my ($arr) = @_;
  my $in_header = 1;
  foreach (@$arr) {
    if ($in_header) {
      $in_header = 0	if $_ eq "\n" || $_ eq "\r\n";
      next;
    }
    if (!$paranoid) {
      s:</body>::;
      s:</html>::;
    }
    print;
  }
}

sub html_quote {
  my $rv = $_[0];
  $rv =~ s:&:\&amp;:g;
  $rv =~ s:>:\&gt;:g;
  $rv =~ s:<:\&lt;:g;
  return "<pre>$rv</pre>\n";
}

sub dir_full_name {
  my ($fn) = $_[0];
  $fn = '' if !defined($fn);
  return $fn if substr($fn,0,1) eq '/';
  return "$tmp_dir$fn" if substr($tmp_dir,0,1) eq '/';
  my $pwd = `pwd`;
  chomp $pwd;
  return "$pwd/$tmp_dir$fn";
}

1; #return true