#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

use strict;
require AutoLoader;

package W3C::Util::W3CDebugCGI::LogEntry;
use W3C::Util::Exception;
use vars qw(%MonStrToNum @MonNumToStr %DayStrToNum @DayNumToStr);

%MonStrToNum = ('Jan' => 1, 
		'Feb' => 2, 
		'Mar' => 3, 
		'Mar' => 4, 
		'Apr' => 5, 
		'Jun' => 6, 
		'Jul' => 7, 
		'Aug' => 8, 
		'Sep' => 9, 
		'Oct' => 10, 
		'Nov' => 11, 
		'Dec' => 12);

@MonNumToStr = (undef, 
		'Jan', 
		'Feb', 
		'Mar', 
		'Mar', 
		'Apr', 
		'Jun', 
		'Jul', 
		'Aug', 
		'Sep', 
		'Oct', 
		'Nov', 
		'Dec');

%DayStrToNum = ('Sun' => 0, 
		'Mon' => 1, 
		'Tue' => 2, 
		'Wed' => 3, 
		'Thu' => 4, 
		'Fri' => 5, 
		'Sat' => 6);

@DayNumToStr = ('Sun', 
		'Mon', 
		'Tue', 
		'Wed', 
		'Thu', 
		'Fri', 
		'Sat');

sub new {
    my ($proto, $headerLineOrNameOrSibling, $entryType) = @_;
    my $class = ref($proto) || $proto;
    my $self;
    if ($entryType) {
	if ($headerLineOrNameOrSibling->isa('W3C::Util::W3CDebugCGI::LogEntry')) {
	    $self = {%$headerLineOrNameOrSibling};
	    $self->{ENTRY_TYPE} = $entryType;
	} else {
	    use Time::HiRes qw/gettimeofday/;
	    my @timestamp = gettimeofday();
	    $self->{SESSION_ID} = $timestamp[0].'.'.$timestamp[1];
	    my $timestamp = $self->{SESSION_ID}.' '.`date`;
	    my $sessionId = $timestamp[0].'.'.$timestamp[1];
	    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
	    $self = {NAME => $headerLineOrNameOrSibling, 
		     ENTRY_TYPE => $entryType, 
		     SESSION_ID => $sessionId, 
		     DAY => $wday,  # should be _name of_ day of week
		     MON => 1+$mon,
		     DATE => $mday,
		     HOUR => $hour,
		     MIN => $min,
		     SEC => $sec,
		     ZONE => $ENV{'TZ'} || 'NA',
		     YEAR => 1900+$year};
	}
    } else {
	if ($headerLineOrNameOrSibling !~ m/^([^\s]+) (\w+ )?([0-9\.]+) (\w+) (\w+)?\s+(\d+) (\d+):(\d+):(\d+) (?:(\w+) )?(\d+)$/) {
	    &throw(new W3C::Util::Exception(-message => "bad header \"$headerLineOrNameOrSibling\""));
	}
	$self = {NAME => $1, 
		 ENTRY_TYPE => $2, 
		 SESSION_ID => $3, 
		 DAY => $DayStrToNum{$4}, 
		 MON => $MonStrToNum{$5}, 
		 DATE => $6, 
		 HOUR => $7, 
		 MIN => $8, 
		 SEC => $9, 
		 ZONE => $10, 
		 YEAR => $11};
	chop $self->{ENTRY_TYPE};
    }
    bless ($self, $class);
    return $self;
}

sub toString {
    my ($self) = @_;
    return sprintf('%s %s %s %s %s %s %s:%s:%s %s %s', $self->{NAME}, 
		   $self->{ENTRY_TYPE}, $self->{SESSION_ID}, $DayNumToStr[$self->{DAY}], 
		   $MonNumToStr[$self->{MON}], $self->{DATE}, $self->{HOUR}, 
		   $self->{MIN}, $self->{SEC}, $self->{ZONE}, $self->{YEAR});
}

sub getIsoDate {
    my ($self) = @_;
    return sprintf('%04d%02d%02d%02d%02d%02d', 
		   $self->{YEAR}, $self->{MON}, $self->{DATE}, 
		   $self->{HOUR}, $self->{MIN}, $self->{SEC});
}

sub getEntryType {
    my ($self) = @_;
    return $self->{ENTRY_TYPE};
}

sub getSessionId {
    my ($self) = @_;
    return $self->{SESSION_ID};
}

sub addField {
    my ($self, $field, $value) = @_;
    $self->{FIELDS}{$field} = $value;
}

sub getField {
    my ($self, $field) = @_;
    return $self->{FIELDS}{$field};
}

sub getFields {
    my ($self) = @_;
    return keys %{$self->{FIELDS}};
}

sub getParms { # static
    return [qw(SESSION_ID
	       DAY
	       MON
	       DATE
	       HOUR
	       MIN
	       SEC
	       ZONE
	       YEAR)];
}

package W3C::Util::W3CDebugCGI;
use Fcntl ':flock'; # import LOCK_* constants
use POSIX qw(mktime);
use CGI;
use W3C::Util::Exception;

use vars qw($REVISION $VERSION $DSLI @ISA @TODO $DEBUG_SESSION 
	    $NEXT $LAST $DELETE_MARKER @EXPORT_OK);
$REVISION = '$Id: W3CDebugCGI.pm,v 1.90 2005/05/18 16:30:13 eric Exp $ ';
@ISA = qw(CGI AutoLoader);
$VERSION = 0.60;
$DSLI = 'adpO';
@TODO = ('figure out how to use strict with filehandles');
@EXPORT_OK = qw(&escapeName &unescapeName $DELETE_MARKER);

$DEBUG_SESSION = undef;
$NEXT = \ 'next';
$LAST = \ 'last';
$DELETE_MARKER = \ 'DELETE_MARKER';

sub new {
    my ($proto, $scriptName, $reUseCGI, $flags) = @_;
    my $class = ref($proto) || $proto;
    $flags = {} if (ref $flags ne 'HASH');

    if ($flags->{'-noStore'}) {
	# shortcut that bypasses all but the POST parms merge
	my $self = $class->makeSuper($flags, {});
	bless ($self, $class);
	return $self;
    }

    my $self = $class->loadOrSave($scriptName, $reUseCGI, $flags);

    # fugly little hack to get the URL (query) parms on a POST
    # This is done after the data is written or restored to allow agents to
    # rerun a session with or without the -mergeQueryAndPOST flag.
    if ($flags->{-mergeQueryAndPOST} && 
	($ENV{'REQUEST_METHOD'} eq 'POST' || $ENV{'REQUEST_METHOD'} eq 'PUT')) {
	# call SUPER as $self->parse_params specifically avoids
	# QUERY_STRINGs on POST and PUT.
	$self->SUPER::parse_params($ENV{'QUERY_STRING'});
    }
    return $self;
}

sub savePair {
    my ($self, $fh) = @_;
    print $fh $self->{CGI_ENTRY}->toString()."\n";
    $self->save($fh);
    print $fh $self->{ENV_ENTRY}->toString()."\n";
    &saveENV($fh);

#	print $fh $scriptName.' cgi '.$timestamp;
#	$self->save($fh);
#	print $fh $scriptName.' env '.$timestamp;
#	&saveENV($fh);
#	flock(SAVE, LOCK_UN);
}

sub loadOrSave {
    my ($class, $scriptName, $reUseCGI, $flags) = @_;
    my $storeIn = $flags->{'-storeIn'};
    my $logExt = $flags->{'-logExt'};
    $scriptName = 'script.pl' if (!defined $scriptName);
    $scriptName =~ s/([^\/]*\/)*//;
    $scriptName =~ m/([\w\-\.]+)/;
    $scriptName = $1;
    $reUseCGI = 0 if (!defined $reUseCGI);
    $storeIn = '/tmp/' if (!defined $storeIn);
    $storeIn .= '/' if($storeIn !~ /\/\Z/);
    my ($baseName, $self);
    #($baseName = $scriptName) =~ s/^.*\/([^\/\.]+).*$/$1/;
    ($baseName = $scriptName) =~ s/^.*\/([^\/]+)$/$1/;
    my $logFileName = $storeIn.$baseName.$logExt;
    if ($reUseCGI) {
	my $rerunSessionId = $flags->{-sessionId} ? $flags->{-sessionId} : $DEBUG_SESSION ? $DEBUG_SESSION : undef;
	$self = &LoadSelf($class, $logFileName, \ $rerunSessionId, $flags);
	if ($ENV{'CONTENT_LENGTH'} > 0 && 0) { # hmm - no worky - maybe i'll play with it later...
	    open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3; sleep 10000000' |];
	    $DB::fork_TTY = <XT>;
	    chomp $DB::fork_TTY;
	    $DB::pid = open(STDOUT, "|-");
	    # continue processing as child of this fork
	    return if ($DB::pid == 0);
	    my @out;
	    foreach my $param ($self->param) {
		push (@out, $param.'='.$self->param($param));
	    }
	    print STDOUT join('&', @out);
	    exit(0);
	}
    } elsif (exists $flags->{-readLog}) {
	my $entries = {};
	if (open(SAVE, $logFileName)) {
	    my $startFrom = \ $NEXT;
	    my $stopAt = \ $LAST;
	    if (my $statsRange = $flags->{-readLog}) {
		my ($from, $to) = split(/\-/, $statsRange, 2);
		if ($from) {
		    $startFrom = &toTimet($from);
		}
		if ($to) {
		    $stopAt = &toTimet($to);
		}
	    }
	    my $fh = \*SAVE;
	    flock($fh, LOCK_SH);
	    seek($fh, 0, 2);
	    flock($fh, LOCK_UN);
	    my $end = tell($fh);
	    seek($fh, 0, 0);
	    my $position;
	    while (($position = tell($fh)) >= 0 && ($position < $end)) {
		eval {
		    my $cgiLogEntry = &LookFor($startFrom, 'cgi', $fh, undef, $flags);
		    if ($stopAt != \ $LAST && $cgiLogEntry->getSessionId() > $stopAt) {
			last;
		    }
		    while (my $line = <$fh>) {
			chomp $line;
			if ($line =~ /^=$/) {
			    last;
			} else {
			    my ($field, $value) = split(/\=/, $line, 2);
			    $value = CGI::unescape($value);
			    $cgiLogEntry->addField($field, $value);
			}
		    }
		    my $envLogEntry = &LookFor($cgiLogEntry->getSessionId(), 'env', $fh, $cgiLogEntry, $flags);
		    while (my $line = <$fh>) {
			chomp $line;
			if ($line =~ /^=$/) {
			    last;
			} else {
			    my ($field, $value) = split(/\=/, $line, 2);
			    $value = CGI::unescape($value);
			    $envLogEntry->addField($field, $value);
			}
		    }
		    $entries->{$cgiLogEntry->getSessionId()}{'cgi'} = $cgiLogEntry;
		    $entries->{$cgiLogEntry->getSessionId()}{'env'} = $envLogEntry;
		    $startFrom = \ $NEXT;
		}; if ($@) {
		    if ($flags->{-ignoreBadHeaders}) {
			while (my $line = <$fh>) {
			    chomp;
			    last if ($line =~ /^=$/);
			}
		    } else {
			die $@;
		    }
		}
	    }
	    close($fh);
	    return $entries;
	} else {
	    &throw(new W3C::Util::Exception(-message => "unable to open \"$logFileName\": $!"));
	}
    } else {
	$self = $class->makeSuper($flags);
	if ($flags->{-rerun} && $self->param($flags->{-rerun})) {
	    # re-run an old session
	    # This is an invitiation to replay attacks. App better check the
	    # ORIG_STATE for authentication of the person replaying the session.
	    my $queryString = $ENV{QUERY_STRING};
	    my $rerunSessionId = $self->param($flags->{-rerun});

	    # load a new self, but keep a pointer to the old one
	    # This is access through ->getRealSession
	    my $realSession = $self;
	    $realSession->copyEnv(\%ENV);
	    $self = &LoadSelf($class, $logFileName, \ $rerunSessionId, $flags);
	    $self->{REAL_SESSION} = $realSession;

	    # assume the state of the new session
	    $self->parse_params($queryString);
	    $self->delete($flags->{-rerun});

	    # handle reconstruct queries through a redirect
	    # Note: fussy apps may not like to reconstruct POST sessions with a GET.
	    if ($flags->{-reconstruct} && $self->param($flags->{-reconstruct})) {
		$self->delete($flags->{-reconstruct});
		print $self->redirect;
		exit(0);
	    }
	} else {
	    $self->{CGI_ENTRY} = new W3C::Util::W3CDebugCGI::LogEntry($scriptName, 'cgi');
	    $self->{ENV_ENTRY} = new W3C::Util::W3CDebugCGI::LogEntry($self->{CGI_ENTRY}, 'env');
	    if (open(SAVE, '>>'.$logFileName)) {
		my $fh = \*SAVE;
		flock($fh, LOCK_EX);
		$self->savePair($fh);
		flock($fh, LOCK_UN);
		close($fh);
	    } elsif ($flags->{-dieNoOpen}) {
		# print "Status: 500\nContent-type: text/plain\n\nunable to open \"$logFileName\": $!";
		&throw(new W3C::Util::Exception(-message => "unable to open \"$logFileName\": $!"));
	    }
	}
    }
    if (defined $ENV{'HTTP_AUTHORIZATION'} && !defined $ENV{'REMOTE_USER'}) {
	# apache's in *that* mode
	my ($scheme, $data) = split (' ', $ENV{'HTTP_AUTHORIZATION'});
	
	if ($scheme eq 'Basic') {
	    $data = &decode_base64 ($data);
	    ($ENV{'REMOTE_USER'}, $ENV{'REMOTE_PASSWORD'}) = split(':', $data);
	    # If a script is running in an env where apache is not doing auth, 
	    # the script must check the password itself.
	}
    }
    bless ($self, $class);
    $self->{ACCEPTS} = {}; # {map {($_ =~ m/(.*?)\;q=(.*)/) ? ($1, $2) : ($_, .999)} split(/[,\s]+/, $ENV{'HTTP_ACCEPT'})};
    while ($ENV{'HTTP_ACCEPT'} =~ m/\G (.*?) \;q\= ([0-9\.]+) \,? /gcxs) {
	my ($q, $list) = ($2, $1);
	foreach my $element (split(/[,\s]+/, $list)) {
	    $self->{ACCEPTS}{$element} = $q;
	}
    }
    {	# I should get around to seeing if these are called before or after 1.0
	my ($q, $list) = (0.999, $ENV{'HTTP_ACCEPT'} =~ m/\G (.*) /gcxs);
	foreach my $element (split(/[,\s]+/, $list)) {
	    $self->{ACCEPTS}{$element} = $q;
	}
    }
    return $self;
}

sub toTimet {
    my ($translateMe) = @_;
    my $ret = undef;
    if ($translateMe =~ m/^\d+\.(\d+)?$/) {
	$ret = $translateMe;
    } elsif ($translateMe =~ m/^(\d\d\d\d)(\d\d)(\d\d)(\d\d)?(\d\d)?(\d\d)?$/) {
	my ($yr, $mn, $dy, $hr, $mnt, $sc) = ($1, $2, $3, $4, $5, $6);
	$ret = mktime($sc, $mnt, $hr, $dy, $mn+1, $yr-1900);
    }
    return $ret;
}

# REAL_SESSION: actual session state. Exists if emulating a difference session.
sub getRealSession {
    my ($self) = @_;
    return $self->{REAL_SESSION};
}

# uriFromProperties - Build a URI from standard path components from the props.
# This will probably move to some utilities file.
use URI;
sub uriFromProperties {
    my ($self, $props, $baseProperty) = @_;
    if (defined $baseProperty) {
	if ($baseProperty ne '' && $baseProperty !~ m/\.$/) {
	    $baseProperty .= '.';
	}
    } else {
	$baseProperty = '';
    }
    my $defaultUri = new URI($self->url);
    my $protocol = 'http';
    my $host = $props->getI("${baseProperty}ServerName") || $defaultUri->host;
    my $port = $props->getI("${baseProperty}Port") || $defaultUri->port;
    my $portStr = $port == 80 ? '' : ":$port";
    my $path = $props->getI("${baseProperty}Path") || $defaultUri->path;
    my $pathStr = substr($path, 0, 1) eq '/' ?  $path : "/$path";
    $pathStr =~ s/\/$//;
    return "$protocol://$host$portStr$pathStr";
}

sub trimmedPath {
    my ($self) = @_;
    my $uri = $ENV{'REQUEST_URI'};
    my $lenQS = length($ENV{'QUERY_STRING'});
    my $len = length($uri)-$lenQS;
    if (substr($uri, $len-1, 1) eq '?' || substr($uri, $len-1, 1) eq '/') {
	$len--;
    }
    return substr($uri, 0, $len);
}

sub trimmedUri {
    my ($self) = @_;
    return "http://$ENV{SERVER_NAME}".$self->trimmedPath();
}

# overload parse_params so we can keep CGI.pm from parsing
# XML sent without a parameter.

sub parse_params {
    my($self,$tosplit) = @_;
    if ($ENV{'REQUEST_METHOD'} eq 'POST' && $ENV{'CONTENT_TYPE'} =~ m/^application\/xml/) {
    } else {
	$self->SUPER::parse_params($tosplit);
    }
}

sub getPOST {
    my ($self) = @_;
    return $self->{-postData};
}

sub getPUT {
    my ($self) = @_;
    return $self->{-putData};
}

# add UTF-8 enforcement
sub paramUTF8 {
    my ($self, $name) = @_;
    my $field = $self->param($name);
    if (defined $field && 
	$field !~ 
	    m/^(
		[\x09\x0A\x0D\x20-\x7E]               # ASCII
	      | [\xC2-\xDF][\x80-\xBF]             # non-overlong 2-byte
	      |  \xE0[\xA0-\xBF][\x80-\xBF]        # excluding overlongs
	      | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}  # straight 3-byte
	      |  \xED[\x80-\x9F][\x80-\xBF]        # excluding surrogates
	      |  \xF0[\x90-\xBF][\x80-\xBF]{2}     # planes 1-3
	      | [\xF1-\xF3][\x80-\xBF]{3}          # planes 4-15
	      |  \xF4[\x80-\x8F][\x80-\xBF]{2}     # plane 16
	    )*$/x) {
	&throw(new W3C::Util::StringEncodingException(-str => $field, -encoding => 'utf-8'));
    }
    return $field;
}

sub makeSuper {
    my ($proto, $flags) = (shift, shift); # remaining args initialize CGI.pm
    my $class = ref($proto) || $proto;
    my $realMethod = $ENV{'REQUEST_METHOD'};
    my $putData = undef;
    if ($ENV{'REQUEST_METHOD'} eq 'PUT') {
	if (my $contentLength = $ENV{'CONTENT_LENGTH'}) {
	    &CGI::read_from_client(undef, \*STDIN, \$putData, $contentLength, 0);
	    $ENV{'REQUEST_METHOD'} = 'GET';
	}
    }

    my $self = $class->SUPER::new(@_);
    $ENV{'REQUEST_METHOD'} = $realMethod;
    if ($putData) {
	$self->{-putData} = $putData;
	$ENV{'PUT_VARS'} = $putData;
    }
    return $self;
}

# maxAccept(choices, flags) - find the best match in between $self->{ACCEPTS}
#			      and the supplied choices. Choices are in the form
#			      {mime/type => [return code, quality], ...} or 
#			      {mime/type => [return code], ...} or 
#			      [mime/type => return code, ...] or 
#			      [mime/type, ...].
#			      flags are in the form {-default => return code}
# This may seem like a bit of a specialized function, but it is common to swich
# between a variety of data formats based on the accept string.

sub maxAccept {
    my ($self, $choices, %flags) = @_;
    my (@ordered, %appQValues, %retCodes);

    # initialize @ordered, %appQValues, %retCodes according to initializer type
    if (ref $choices eq 'ARRAY') {
	if (@$choices <= 1 || $choices->[1] =~ m:\w+/\w+:) {
	    # [mime/type, ...]
	    for (my $i = 0; $i < @$choices; $i++) {
		my $mimeType = $choices->[$i];
		my $retCode = $mimeType;
		push (@ordered, $mimeType);
		$retCodes{$mimeType} = $retCode;
		$appQValues{$mimeType} = 0;
	    }
	} else {
	    # [mime/type => return code, ...]
	    for (my $i = 0; $i < @$choices; $i+=2) {
		my $mimeType = $choices->[$i];
		my $retCode = $choices->[$i+1];
		push (@ordered, $mimeType);
		$retCodes{$mimeType} = $retCode;
		$appQValues{$mimeType} = 0;
	    }
	}
    } elsif (ref $choices eq 'HASH') {
	# {mime/type => [return code, quality], ...}
	my %mimeTypesByValue;
	my %retCodesByValue;
	# build hashes by value
	foreach my $mimeType (keys %$choices) {
	    my ($retCode, $appQValue) = @{$choices->{$mimeType}};
	    # {mime/type => [return code], ...}
	    $appQValue = 1 if (!defined $appQValue);
	    push (@{$mimeTypesByValue{$appQValue}}, $mimeType);
	    push (@{$retCodesByValue{$appQValue}}, $retCode);
	}
	# push sort byValue hashes and push into @ordered %appQValues %retCodes
	foreach my $appQValue (reverse sort keys %mimeTypesByValue) {
	    for (my $i = 0; $i < @{$mimeTypesByValue{$appQValue}}; $i++) {
		my $mimeType = $mimeTypesByValue{$appQValue}[$i];
		my $retCode = $retCodesByValue{$appQValue}[$i];
		push (@ordered, $mimeType);
		$retCodes{$mimeType} = $retCode;
		$appQValues{$mimeType} = $appQValue;
	    }
	}
    } else {
	&throw(new W3C::Util::ParameterException(-parameter => '$choices'));
    }

    # crawl through @ordered for best match
    my ($best, $maxQValue) = (undef, undef);
    for (my $i = 0; $i < @ordered; $i++) {
	my $testMimeType = $ordered[$i];
	my $appQValue = $appQValues{$testMimeType};
	my $matched = undef;

	# See if we have any accepts that match this pattern.
	if ($testMimeType =~ m/\*/) {
	    # Turn a copy of the test into a regexp.
	    my $copy = $testMimeType;
	    $copy =~ s/\*/\.\*/g;
	    # This cursory escaping only works with polite mimetype patterns.
	    $copy =~ s/\+/\\\+/g;
	    foreach my $accept (keys %{$self->{ACCEPTS}}) {
		if ($accept =~ m/^$copy$/) {
		    $matched = $accept;
		    last;
		}
	    }
	} elsif (exists $self->{ACCEPTS}{$testMimeType}) {
	    $matched = $testMimeType;
	}

	if (defined $matched) {
	    my $clientQValue = $self->{ACCEPTS}{$matched};
	    # Got a match. See if it's better than we already have.
	    if ((!defined $maxQValue || $clientQValue + $appQValue > $maxQValue)) {
		$best = $testMimeType;
		$maxQValue = $self->{ACCEPTS}{$matched};
	    }
	}
    }
    return $best ? ($best, $retCodes{$best}) : $flags{-default} ? ($flags{-default}, $retCodes{$flags{-default}}) : (undef, undef);
}

sub LoadSelf {
    my ($class, $logFileName, $lookForRef, $flags) = @_;
    my $newSelf;
    if (open(SAVE, $logFileName)) { # !!! synchronization problem
	flock(SAVE, LOCK_SH);
	my $fh = \*SAVE;
	if (!$$lookForRef) {
	    $$lookForRef = \ $LAST;
	}
	my $cgiEntry = &LookFor($$lookForRef, 'cgi', $fh, $flags);
	if ($$lookForRef == $LAST) {
	    $$lookForRef = $cgiEntry->getSessionId();
	}
	delete $ENV{REQUEST_METHOD}; # avoid special PUT code when rerunning
	$newSelf = $class->makeSuper($flags, $fh);
	$newSelf->{CGI_ENTRY} = $cgiEntry;
	$newSelf->{ENV_ENTRY} = &LookFor($$lookForRef, 'env', $fh, $flags);
	&loadENV($fh);
	close($fh);
	flock(SAVE, LOCK_UN);
	if ($ENV{REQUEST_METHOD} eq 'POST') {
	    $newSelf->{-postData} = $ENV{POST_VARS};
	}
	if ($ENV{REQUEST_METHOD} eq 'PUT') {
	    $newSelf->{-putData} = $ENV{PUT_VARS};
	}
    } else {
	if ($flags->{-dieNoOpen}) {
	    &throw(new W3C::Util::Exception(-message => "unable to open \"$logFileName\": $!"));
	}
	# should I fake CGI_ENTRY and ENV_ENTRY ? dunno. will wait for use case.
	$newSelf = $class->makeSuper($flags);
    }
    return $newSelf;
}

# overloaded function so we can grab the POST_STRING

sub read_from_client {
    my ($self, $fh, $buff, $len, $offset) = @_;
    local $^W=0;                # prevent a warning
    my $ret;
    if ($CGI::VERSION >= 3) {
	($self, $buff, $len, $offset) = @_;
	$ret = read(\*STDIN, $$buff, $len, $offset);
    } else {
	return undef unless defined($fh);
	no strict; # 'cause CGI.pm insists on passing filehandles around by name, not GLOB
	my $ret = read($fh, $$buff, $len, $offset);
	use strict;
    }
    if ($ENV{REQUEST_METHOD} eq 'POST') {
	$self->{-postData} = $ENV{POST_VARS} = $$buff;
    }
    if ($ENV{REQUEST_METHOD} eq 'PUT') {
	$self->{-putData} = $ENV{PUT_VARS} = $$buff;
    }
    return $ret;
}

sub getSessionId {
    my ($self) = @_;
    return $self->{CGI_ENTRY}->getSessionId();
}

sub LookFor {
    my ($lookFor, $lookForType, $fh, $flags) = @_;
    $lookFor = \ $LAST if (!defined $lookFor);
    my ($lastId, $found, $headerLine, $logEntry) = (undef, 0, undef, undef);
    my @positions;
    while (!eof($fh)) {
	my $position = tell($fh);
	$headerLine = <$fh>;
	chomp $headerLine;
	eval {
	    $logEntry = new W3C::Util::W3CDebugCGI::LogEntry($headerLine);
	}; if ($@) {
	    if ($flags->{-ignoreBadHeaders}) {
		while (my $line = <$fh>) {
		    chomp;
		    last if ($line =~ /^=$/);
		}
	    } else {
		die $@;
	    }
	}
	if (!defined $logEntry->getEntryType() || !defined $lookForType || $logEntry->getEntryType() eq $lookForType) {
	    if ($lookFor == $logEntry->getSessionId() || $lookFor == \ $NEXT) {
		$found = $lookFor;
		last;
	    } else {
		$lastId = $logEntry->getSessionId();
		push (@positions, $position);
	    }
	}
	while (my $line = <$fh>) {
	    chomp $line;
	    last if ($line =~ /^=$/);
	}
    }
    if ($found) {
	return $logEntry;
    } elsif ($lookFor == \ $LAST || $lookFor =~ m/^\-?\d+$/) {
	my $index = ($lookFor == \ $LAST) ? -1 : $lookFor;
	seek($fh, $positions[$index], 0);
	my $headerLine = <$fh>;
	my $logEntry = new W3C::Util::W3CDebugCGI::LogEntry($headerLine);
	return $logEntry;
    } else {
	&throw(new W3C::Util::Exception(-message => "didn't find session $lookFor"));
    }
}

sub saveENV {
    my $filehandle = shift;
    $filehandle = &CGI::to_filehandle($filehandle);
    foreach my $key (keys %ENV) {
	my $escKey = &CGI::escape($key);
	my $value = $ENV{$key};
	print $filehandle "$escKey=",&CGI::escape($value),"\n";
    }
    print $filehandle "=\n";    # end of record
}

sub copyEnv {
    my ($self, $pEnv) = @_;
    foreach my $key (keys %$pEnv) {
	$self->{ENV}{$key} = $pEnv->{$key};
    }
}

sub getEnv {
    my ($self, $variable) = @_;
    return $self->{ENV}{$variable};
}

sub setEnv {
    my ($self, $variable, $value) = @_;
    $self->{ENV}{$variable} = $value;
}

sub loadENV {
    require "shellwords.pl";
    my $filehandle = shift;
    $filehandle = &CGI::to_filehandle($filehandle);
    %ENV = ();
    foreach my $input (<$filehandle>) {
	chomp($input);
	last if ($input eq '=');
	$input = &CGI::unescape($input);
	my ($key, $value) = split(/=/, $input, 2);
	$ENV{$key} = $value;
    }
}

# libwww-perl 5.0.6 base64 decoder:
#
#Copyright 1995, 1996 Gisle Aas.
#
#This library is free software; you can redistribute it and/or
#modify it under the same terms as Perl itself.
#
#Gisle Aas <aas@sn.no>
#
#Based on LWP::Base64 written by Martijn Koster <m.koster@nexor.co.uk>
#and Joerg Reichelt <j.reichelt@nexor.co.uk> and code posted to
#comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans Mulder
#<hansm@wsinti07.win.tue.nl>
#
#=cut                      

sub decode_base64 {
    my ($str) = "@_";
    my ($res, $len) = "";
    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]


    $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
    Carp::croak("Base64 decoder requires string length to be a multiple of 4")
      if length($str) % 4;
    $str =~ s/=+$//;                        # remove padding
    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
    while ($str =~ /(.{1,60})/gs) {
        $len = chr(32 + length($1)*3/4); # compute length byte
        $res .= unpack("u", $len . $1 );    # uudecode
    }
    return ($res);
}

# convert "http://quake.w3.org/Phonelist.php3" <=> "http://quake.w3.org/Phonelist.php3"
sub escapeName ($) {
    my $toEscape = shift;
    $toEscape = shift if (ref $toEscape);
    my $a = CGI::escape($toEscape);
    $a =~ s/_/_u/g;
    $a =~ s/\%/_p/g;
    $a =~ s/\./_d/g;
    $a =~ s/\-/_h/g;
    $a =~ s/\&/_a/g;
    $a =~ s/\=/_e/g;
    return $a;
}

sub unescapeName ($) {
    my $toEscape = shift;
    $toEscape = shift if (ref $toEscape);
    $a = $toEscape;
    $a =~ s/_e/\=/g;
    $a =~ s/_a/\&/g;
    $a =~ s/_h/\-/g;
    $a =~ s/_d/\./g;
    $a =~ s/_p/\%/g;
    $a =~ s/_u/_/g;
    $a = CGI::unescape($a);
    return $a;
}

sub cacheHidden {
    my ($self, $attr, $value) = (@_);
    my $ret = "<input type=\"hidden\" name=\"$attr\" value=\"$value\" />";
    push (@{$self->{CACHE}{HIDDEN}}, $attr.'='.$self->escape($value));
    return $ret;
}

sub showCache {
    my ($self) = @_;
    my @ret;
    foreach my $key (keys %{$self->{CACHE}}) {
	push (@ret, join ('&', @{$self->{CACHE}{$key}}));
    }
    return join ('&', @ret);
}

sub hidden1 {
    my ($self, $name, @values) = @_;
    $self->param($name, @values);
    return $self->SUPER::hidden($name, @values);
}

# ------------------- overload CGI.pm to spit out XHTML ---------------------
sub checkbox999 {
    my($self,@p) = @_;

    my($name,$checked,$value,$label,$override,@other) = 
	$self->rearrange(['NAME',['CHECKED','SELECTED','ON'],'VALUE','LABEL',['OVERRIDE','FORCE']],@p);
    
    $value = defined $value ? $value : 'on';

    if (!$override && ($self->{'.fieldnames'}->{$name} || 
		       defined $self->param($name))) {
	$checked = grep($_ eq $value,$self->param($name)) ? ' checked="checked"' : '';
    } else {
	$checked = $checked ? ' checked="checked"' : '';
    }
    my($the_label) = defined $label ? $label : $name;
    $name = $self->escapeHTML($name);
    $value = $self->escapeHTML($value);
    $the_label = $self->escapeHTML($the_label);
    my($other) = @other ? " @other" : '';
    $self->register_parameter($name);
    return <<END;
<input type="checkbox" name="$name" value="$value"$checked$other />$the_label
END
}

sub checkbox_group999 {
    my($self,@p) = @_;

    my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
       $rowheaders,$colheaders,$override,$nolabels,@other) =
	$self->rearrange(['NAME',['VALUES','VALUE'],['DEFAULTS','DEFAULT'],
			  'LINEBREAK','LABELS','ROWS',['COLUMNS','COLS'],
			  'ROWHEADERS','COLHEADERS',
			  ['OVERRIDE','FORCE'],'NOLABELS'],@p);

    my($checked,$break,$result,$label);

    my(%checked) = $self->previous_or_default($name,$defaults,$override);

    $break = $linebreak ? "<br />" : '';
    $name=$self->escapeHTML($name);

    # Create the elements
    my(@elements,@values);

    @values = $self->_set_values_and_labels($values,\$labels,$name);

    my($other) = @other ? " @other" : '';
    foreach (@values) {
	$checked = $checked{$_} ? ' checked="checked"' : '';
	$label = '';
	unless (defined($nolabels) && $nolabels) {
	    $label = $_;
	    $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
	    $label = $self->escapeHTML($label);
	}
	$_ = $self->escapeHTML($_);
	push(@elements,qq/<input type="checkbox" name="$name" value="$_"$checked$other \/>${label}${break}/);
    }
    $self->register_parameter($name);
    return wantarray ? @elements : join(' ',@elements)            
        unless defined($columns) || defined($rows);
    return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}

sub radio_group999 {
    my($self,@p) = @_;

    my($name,$values,$default,$linebreak,$labels,
       $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
	$self->rearrange(['NAME',['VALUES','VALUE'],'DEFAULT','LINEBREAK','LABELS',
			  'ROWS',['COLUMNS','COLS'],
			  'ROWHEADERS','COLHEADERS',
			  ['OVERRIDE','FORCE'],'NOLABELS'],@p);
    my($result,$checked);

    if (!$override && defined($self->param($name))) {
	$checked = $self->param($name);
    } else {
	$checked = $default;
    }
    my(@elements,@values);
    @values = $self->_set_values_and_labels($values,\$labels,$name);

    # If no check array is specified, check the first by default
    $checked = $values[0] unless defined($checked) && $checked ne '';
    $name=$self->escapeHTML($name);

    my($other) = @other ? " @other" : '';
    foreach (@values) {
	my($checkit) = $checked eq $_ ? ' checked="checked"' : '';
	my($break) = $linebreak ? '<br />' : '';
	my($label)='';
	unless (defined($nolabels) && $nolabels) {
	    $label = $_;
	    $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
	    $label = $self->escapeHTML($label);
	}
	$_=$self->escapeHTML($_);
	push(@elements,qq/<input type="radio" name="$name" value="$_"$checkit$other>${label}${break}/);
    }
    $self->register_parameter($name);
    return wantarray ? @elements : join(' ',@elements) 
           unless defined($columns) || defined($rows);
    return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}

sub popup_menu999 {
    my($self,@p) = @_;

    my($name,$values,$default,$labels,$override,@other) =
	$self->rearrange(['NAME',['VALUES','VALUE'],['DEFAULT','DEFAULTS'],'LABELS',['OVERRIDE','FORCE']],@p);
    my($result,$selected);

    if (!$override && defined($self->param($name))) {
	$selected = $self->param($name);
    } else {
	$selected = $default;
    }
    $name=$self->escapeHTML($name);
    my($other) = @other ? " @other" : '';

    my(@values);
    @values = $self->_set_values_and_labels($values,\$labels,$name);

    $result = qq/<select name="$name"$other>\n/;
    foreach (@values) {
	my($selectit) = defined($selected) ? ($selected eq $_ ? 'selected="selected"' : '' ) : '';
	my($label) = $_;
	$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
	my($value) = $self->escapeHTML($_);
	$label=$self->escapeHTML($label);
	$result .= "<option $selectit value=\"$value\">$label</option>\n";
    }

    $result .= "</select>\n";
    return $result;
}

sub scrolling_list999 {
    my($self,@p) = @_;
    my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
	= $self->rearrange(['NAME',['VALUES','VALUE'],['DEFAULTS','DEFAULT'],
			    'SIZE','MULTIPLE','LABELS',['OVERRIDE','FORCE']],@p);

    my($result,@values);
    @values = $self->_set_values_and_labels($values,\$labels,$name);

    $size = $size || scalar(@values);

    my(%selected) = $self->previous_or_default($name,$defaults,$override);
    my($is_multiple) = $multiple ? ' multiple="multiple"' : '';
    my($has_size) = $size ? " size=\"$size\"" : '';
    my($other) = @other ? " @other" : '';

    $name=$self->escapeHTML($name);
    $result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
    foreach (@values) {
	my($selectit) = $selected{$_} ? 'selected="selected"' : '';
	my($label) = $_;
	$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
	$label=$self->escapeHTML($label);
	my($value)=$self->escapeHTML($_);
	$result .= "<option $selectit value=\"$value\">$label</option>\n";
    }
    $result .= "</select>\n";
    $self->register_parameter($name);
    return $result;
}

# ------------------- end overload CGI.pm to spit out XHTML ---------------------

sub self_or_default1 {
    return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
    my $Q;
    unless (defined($_[0]) && 
	    (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
	    ) {
	$Q = $CGI::DefaultClass->new unless defined($Q);
	unshift(@_,$Q);
    }
    return @_;
}

#'submit1' => <<'END_OF_FUNC',
sub submit {
    my($self,@p) = self_or_default1(@_);

    my($label,$value,@other) = $self->rearrange(['NAME',['VALUE','LABEL']],@p);

    $label=$self->escapeHTML($label);
    $value=$self->escapeHTML($value);

    my($name) = ' NAME=".submit"';
    $name = qq/ NAME="$label"/ if defined($label);
    $value = defined($value) ? $value : $label;
    my($val) = '';
    $val = qq/ VALUE="$value"/ if defined($value);
    my($other) = @other ? " @other" : '';
    return qq/<INPUT TYPE="submit"$name$val$other>/;
}
#END_OF_FUNC

#sub appendDump { # static
#    my ($str, $location) = @_;
#    my $date = `date`;
#    open (DUMP, ">>/tmp/asdf3");
#    print DUMP $date;
#    print DUMP $location, "\n";
#    print DUMP $str;
#    close DUMP;
#}

1;

__END__

=head1 NAME

W3C::Util::W3CDebugCGI - CGI wrapper to help debug CGIs

=head1 SYNOPSIS

  use W3C::Util::W3CDebugCGI;
  $W3C::Util::W3CDebugCGI::DEBUG_SESSION = $ARGV[1];
  $query = new W3C::Util::W3CDebugCGI($0, $ARGV[0] eq 'DEBUG');
  # and call the script with a 'DEBUG' argument


=head1 DESCRIPTION

CGI wrapper to help debug CGIs.

The script normally calls W3CDebugCGI to get the GET and POST parms.
W3CDebugCGI stores them in a log file each time the script is called.
When the maintainer wishes to debug, he/she calls the script so the
script constructs a W3CDebugCGI object with the $reUseCGI parameter
set to 1. This causes W3CDebugCGI to read from the log file and rerun
a session.  The SYNOPSIS describes a common use where invoking the
script with the argument "DEBUG" enable debugging and the session to
rerun is taken from th second argument.  Rember that the web server
does not call CGI scritps with any arguments so this is a safe way to
pass the debug flag.

This module is part of the W3C::Utils CPAN module.

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut

