File Coverage

blib/lib/Apache/ASP/Response.pm

Criterion	Covered	Total	%
statement	326	454	71.8
branch	158	286	55.2
condition	54	110	49.0
subroutine	27	41	65.8
pod	0	32	0.0
total	565	923	61.2

package Apache::ASP::Response;

use Apache::ASP::Collection;

use strict;
no strict qw(refs);
use vars qw(@ISA @Members %LinkTags $TextHTMLRegexp);
@ISA = qw(Apache::ASP::Collection);
use Carp qw(confess);
use Data::Dumper qw(DumperX);
use bytes;

@Members = qw( Buffer Clean ContentType Expires ExpiresAbsolute Status );

# used for session id auto parsing
%LinkTags = (
	     'a' => 'href',
	     'area' => 'href',
	     'form' => 'action',
	     'frame' => 'src',
	     'iframe' => 'src',
	     'img' => 'src',
	     'input' => 'src',
	     'link' => 'href',
	    );

$TextHTMLRegexp = '^text/html(;|$)';

sub new {
    my $asp = shift;

    my $r = $asp->{'r'};
    my $out = '';

    my $self = bless
      {
       asp => $asp,
       out => \$out,
       # internal extension allowing various scripts like Session_OnStart
       # to end the same response
       #       Ended => 0,
       CacheControl => 'private',
       CH => &config($asp, 'CgiHeaders') || 0,
       #       Charset => undef,
       Clean => &config($asp, 'Clean') || 0,
       Cookies => bless({}, 'Apache::ASP::Collection'),
       ContentType => 'text/html',
       'Debug' => $asp->{dbg},
       FormFill => &config($asp, 'FormFill'),
       IsClientConnected => 1,
       #       PICS => undef,
       #       Status => 200,
       #       header_buffer => '',
       #       header_done => 0,
       Buffer => &config($asp, 'BufferingOn', undef, 1),
       BinaryRef => \$out,
       CompressGzip => ($asp->{compressgzip} and ($asp->{headers_in}->get('Accept-Encoding') =~ /gzip/io)) ? 1 : 0,
       r => $r,
       headers_out => scalar($r->headers_out()),
      };

    &IsClientConnected($self); # update now

    $self;
}

sub DeprecatedMemberAccess {
    my($self, $member, $value) = @_;
    $self->{asp}->Out(
		      "\$Response->$member() deprecated.  Please access member ".
		      "directly with \$Response->{$member} notation"
		     );
    $self->{$member} = $value;
}

# defined the deprecated subs now, so we can loose the AUTOLOAD method
# the AUTOLOAD was forcing us to keep the DESTROY around
for my $member ( @Members ) {
    my $subdef = "sub $member { shift->DeprecatedMemberAccess('$member', shift); }";
    eval $subdef;
    if($@) {
	die("error defining Apache::ASP::Response sub -- $subdef -- $@");
    }
}

sub AddHeader {
    my($self, $name, $value) = @_;

    my $lc_name = lc($name);

    if($lc_name eq 'set-cookie') {
	$self->{r}->err_headers_out->add($name, $value);
    } else {
	# if we have a member API for this header, set that value instead
	# to avoid duplicate headers from being sent out
	if($lc_name eq 'content-type') {
	    $self->{ContentType} = $value;
	} elsif($lc_name eq 'cache-control') {
	    $self->{CacheControl} = $value;
	} elsif($lc_name eq 'expires') {
	    $self->{ExpiresAbsolute} = $value;
	} else {
	    $self->{headers_out}->set($name, $value);
	}
    }
}

sub AppendToLog { shift->{asp}->Log(@_); }
sub Debug {
    my $self = shift;
    $self->{Debug} && $self->{asp}->Out("[$self->{asp}{basename}]", @_);
};

sub BinaryWrite {
    $_[0]->Flush();
    $_[0]->{asp}{dbg} && $_[0]->{asp}->Debug("binary write of ".length($_[1])." bytes");
    &Write;
}

sub Clear { my $out = shift->{out}; $$out = ''; }

sub Cookies {
    my($self, $name, $key, $value) = @_;
    if(defined($name) && defined($key) && defined($value)) {
	$self->{Cookies}{$name}{$key} = $value;
    } elsif(defined($name) && defined($key)) {
	# we are assigning cookie with name the value of key
	if(ref $key) {
	    # if a hash, set the values in it to the keys values
	    # we don't just assign the ref directly since for PerlScript
	    # compatibility
	    while(my($k, $v) = each %{$key}) {
		$self->{Cookies}{$name}{$k} = $v;
	    }
	} else {
	    $self->{Cookies}{$name}{Value} = $key;
	}
    } elsif(defined($name)) {
	# if the cookie was just stored as the name value, then we will
	# will convert it into its hash form now, so we can store other
	# things.  We will probably be storing other things now, since
	# we are referencing the cookie directly
	my $cookie = $self->{Cookies}{$name} || {};
	$cookie = ref($cookie) ? $cookie : { Value => $cookie };
	$self->{Cookies}{$name} = bless $cookie, 'Apache::ASP::Collection';
    } else {
	$self->{Cookies};
    }
}

sub End {
    my $self = shift;
    # by not calling EndSoft(), but letting it be called naturally after
    # Execute() in hander(), we allow more natural Buffer flushing to occur
    # even if we are in a situation where Flush() has been made null like
    # in an XMLSubs or cached or trapped include
#    &EndSoft($self);
    eval { goto APACHE_ASP_EXECUTE_END; };
}

sub EndSoft {
    my $self = shift;
    return if $self->{Ended}++;
    &Flush($self);
}

sub Flush {
    my $self = shift;
    my $asp = $self->{asp};
    my $out = $self->{out};
    local $| = 1;

    # Script_OnFlush event handler
    $asp->{GlobalASA}{'exists'} &&
      $asp->{GlobalASA}->ScriptOnFlush();

    # XSLT Processing, check for errors so PrettyError() can call Flush()
    if($asp->{xslt} && ! $asp->{errs}) {
	$asp->{dbg} && $asp->Debug("pre xslt $out length: ".length($$out));
	$self->FlushXSLT;
	$asp->{dbg} && $asp->Debug("post xslt $out length: ".length($$out));
	return if $asp->{errs};
    }

    # FormFill
    if ($self->{FormFill} && ! $asp->{errs}) {
	$self->FormFill;
	return if $asp->{errs};
    }

    if($self->{Clean} and $self->{ContentType} =~ /$TextHTMLRegexp/o) {
	# by checking defined, we just check once
	unless(defined $Apache::ASP::CleanSupport) {
	    eval 'use HTML::Clean';
	    if($@) {
		$self->{asp}->Log("Error loading module HTML::Clean with Clean set to $self->{Clean}. ".
				  "Make user you have HTML::Clean installed properly. Error: $@");
		$Apache::ASP::CleanSupport = 0;
	    } else {
		$Apache::ASP::CleanSupport = 1;
	    }
	}

	# if we can't clean, we simply ignore
	if($Apache::ASP::CleanSupport) {
	    my $h = HTML::Clean->new($out, $self->{Clean});
	    if($h) {
		$h->strip();
	    } else {
		$self->{asp}->Error("clean error: $! $@");
	    }
	}
    }

    ## Session query auto parsing for cookieless sessions
    if(
       $asp->{Session}
       and ! $asp->{session_cookie}
       and $asp->{session_url_parse}
       and ($self->{ContentType} =~ /^text/i)
      )
      {
	  $self->SessionQueryParse();
      }

    if($self->{Ended}) {
	# log total request time just once at the end
	# and append to html like Cocoon, per user request
	my $total_time = sprintf('%7.5f', ( eval { &Time::HiRes::time() } || time() ) - $asp->{start_time});
	$asp->{dbg} && $asp->Debug("page executed in $total_time seconds");
	$asp->{total_time} = $total_time;

	if(&config($asp, 'TimeHiRes')) {
	    if($self->{ContentType} =~ /$TextHTMLRegexp/o) {
		if(&config($asp, 'Debug')) {
		    $$out .= "\n";
		}
	    }
	}
    }

    # HEADERS AFTER CLEAN, so content-length would be calculated correctly
    # if this is the first writing from the page, flush a newline, to
    # get the headers out properly
    if(! $self->{header_done}) {
	# if no headers and the script has ended, we know that the
	# the script has not been flushed yet, which would at least
	# occur with buffering on
	if($self->{Ended}) {
	    # compression & content-length settings will kill filters
	    # after Apache::ASP
	    if(! $asp->{filter}) {
		# gzip the buffer if CompressGzip && browser accepts it &&
		# the script is flushed once
		if($self->{CompressGzip} && $asp->LoadModule('Gzip','Compress::Zlib')) {
		    $self->{headers_out}->set('Content-Encoding','gzip');
		    $$out = Compress::Zlib::memGzip($out);
		}

		$self->{headers_out}->set('Content-Length', length($$out));
	    }
	}

	&SendHeaders($self);
    }

    if($asp->{filter}) {
	print STDOUT $$out;
    } else {
	# just in case IsClientConnected is set incorrectly, still try to print
	# the worst thing is some extra error messages in the error_log ...
	# there have been spurious error reported with the IsClientConnected
	# code since it was introduced, and this will limit the errors ( if any are left )
	# to the users explicitly using this functionality, --jc 11/29/2001
	#
#	if($self->{IsClientConnected}) {
	    if(! defined $self->{Status} or ($self->{Status} >= 200 and $self->{Status} < 400)) {
		$self->{r}->print($$out);
	    }
#	}
    }

    # update after flushes only, expensive call
    $self->{Ended} || &IsClientConnected($self);

    # supposedly this is more efficient than undeffing, since
    # the string does not let go of its allocated memory buffer
    $$out = '';

    1;
}

sub FormFill {
    my $self = shift;
    my $asp = $self->{asp};

    $asp->{dbg} && $asp->Debug("form fill begin");
    $asp->LoadModule('FormFill', 'HTML::FillInForm') || return;
    my $ref = $self->{BinaryRef};

    $$ref =~ s/(\]*\>.*?\<\/form\>)/
	     {
		 my $form = $1;
		 my $start_length = $asp->{dbg} ? length($form) : undef;
		 eval {
		     my $fif = HTML::FillInForm->new();
		     $form = $fif->fill(
					scalarref => \$form,
					fdat =>	$asp->{Request}{Form},
					);
		 };
		 if($@) {
		     $asp->CompileErrorThrow($form, "form fill failed: $@");
		 } else {
		     $asp->{dbg} &&
			 $asp->Debug("form fill for form of start length $start_length ".
				     "end length ".length($form));
		 }
		 $form;
	     }
	     /iexsg;

    1;
}

sub FlushXSLT {
    my $self = shift;
    my $asp = $self->{asp};
    my $xml_out = $self->{BinaryRef};
    return unless length($$xml_out); # could happen after a redirect

    $asp->{xslt_match} = &config($asp, 'XSLTMatch') || '^.';
    return unless ($asp->{filename} =~ /$asp->{xslt_match}/);

    ## XSLT FETCH & CACHE
    $asp->{dbg} && $asp->Debug("xslt processing with $asp->{xslt}");
    my $xsl_dataref = $self->TrapInclude($asp->{xslt});
    $asp->{dbg} && $asp->Debug(length($$xsl_dataref)." bytes in XSL $xsl_dataref");
    return if($asp->{errs});

    ## XSLT XML RENDER
    eval {
	my $xslt_data = $asp->XSLT($xsl_dataref, $xml_out);
	$asp->{dbg} && $asp->Debug("xml_out $xml_out length ".length($$xml_out)." set to $xslt_data length ".
				   length($$xslt_data));
	${$self->{BinaryRef}} = $$xslt_data;
    };
    if($@) {
	$@ =~ s/^\s*//s;
	$asp->Error("XSLT/XML processing error: $@");
	return;
    }

    1;
}

sub IsClientConnected {
    my $self = shift;
    return(0) if ! $self->{IsClientConnected};

    # must init Request first for the aborted test to be meaningful.
    # it seems that under mod_perl 1.25, apache 1.20 on a fast local network,
    # if $r->connection->aborted is checked on a file upload before $Request
    # is initialized, then aborted will return true, even under normal use.
    # This causes a file upload script to not render any output.  It may be that this
    # check was done too fast for apache, where it might have still been setting
    # up the upload, so not to check the outbound client connection yet
    #
    unless($self->{asp}{Request}) {
	$self->{asp}->Out("need to init Request object before running Response->IsClientConnected");
	return 1;
    }

    # IsClientConnected ?  Might already be disconnected for busy site, if
    # a user hits stop/reload
    my $conn = $self->{r}->connection;
    my $is_connected = $conn->aborted ? 0 : 1;

    if($is_connected) {
	my $fileno = eval { $conn->fileno };
	if(defined $fileno) {
	    #    sleep 3;
	    #	    my $s = IO::Select->new($fileno);
	    #	    $is_connected = $s->can_read(0) ? 0 : 1;

	    # much faster than IO::Select interface() which calls
	    # a few perl OO methods to construct & then can_read()
	    my $bits = '';
	    vec($bits, $fileno, 1) = 1;
	    $is_connected = select($bits, undef, undef, 0) > 0 ? 0 : 1;
	    if(! $is_connected) {
		$self->{asp}{dbg} && $self->{asp}->Debug("client is no longer connected, detected via Apache->request->connetion->fileno");
	    }
	}
    }

    $self->{IsClientConnected} = $is_connected;
    if(! $is_connected) {
	$self->{asp}{dbg} && $self->{asp}->Debug("client is no longer connected");
    }

    $is_connected;
}

# use the apache internal redirect?  Thought that would be counter
# to portability, but is still something to consider
sub Redirect {
    my($self, $location) = @_;
    my $asp = $self->{asp};
    my $r = $self->{r};

    $asp->{dbg} && $asp->Debug('redirect called', {location=>$location});

    # X: maybe this instead, so no session-id on normal redirects?
    #    if($asp->{Session}) {
    #	$location = $asp->{Server}->URL($location);

    if($asp->{Session} and $asp->{session_url_parse}) {
	$location = &SessionQueryParseURL($self, $location);
	$asp->{dbg} && $asp->Debug("new location after session query parsing $location");
    }

    $r->headers_out->set('Location', $location);
    $self->{Status} = 302;
    $r->status(302);

    # Always SendHeaders() immediately for a Redirect() ... only in a SoftRedirect
    # will execution continue.  Since we call SendHeaders here, instead of
    # Flush() a Redirect() will still work even in a XMLSubs call where Flush is
    # trapped to Null()
    &SendHeaders($self);

    # if we have soft redirects, keep processing page after redirect
    if(&config($asp, 'SoftRedirect')) {
	$asp->Debug("redirect is soft, headers already sent");
    } else {
	# do we called End() or EndSoft() here?  As of v 2.33, End() will
	# just jump to the end of Execute(), so if we were in a XMLSubs
	# and called End() after doing a Clear() there would still be
	# output the gets flushed out from before the XMLSubs, to prevent
	# this we clear the buffer now, and called EndSoft() in this case.
	# Finally we also call End() so we will jump out of the executing code.
	#
	&Clear($self);
	$self->{Ended} = 1; # just marked Ended so future EndSoft() cannot be called
#	&EndSoft($self);
	&End($self);
    }

    1;
}

sub SendHeaders {
    my $self = shift;
    my $r = $self->{r};
    my $asp = $self->{asp};
    my $dbg = $asp->{dbg};
    my $status = $self->{Status};

    return if $self->{header_done};
    $self->{header_done} = 1;

    $dbg && $asp->Debug('building headers');
    $r->status($status) if defined($status);

    # for command line script
    return if &config($asp, 'NoHeaders');

    if(defined $status and $status == 401) {
	$dbg && $asp->Debug("status 401, note basic auth failure realm ".$r->auth_name);

	# we can't send out headers, and let Apache use the 401 error doc
	# But this is fine, once authorization is OK, then the headers
	# will go out correctly, so things like sessions will work fine.
	$r->note_basic_auth_failure;
	return;
    } else {
	$dbg && defined $status && $self->{asp}->Debug("status $status");
    }

    if(defined $self->{Charset}) {
	$r->content_type($self->{ContentType}.'; charset='.$self->{Charset});
    } else {
	$r->content_type($self->{ContentType}); # add content-type
    }

    if(%{$self->{'Cookies'}}) {
	&AddCookieHeaders($self);     # do cookies
    }

    # do the expiration time
    if(defined $self->{Expires}) {
	my $ttl = $self->{Expires};
	$r->headers_out->set('Expires', &Apache::ASP::Date::time2str(time()+$ttl));
	$dbg && $self->{asp}->Debug("expires in $self->{Expires}");
    } elsif(defined $self->{ExpiresAbsolute}) {
	my $date = $self->{ExpiresAbsolute};
	my $time = &Apache::ASP::Date::str2time($date);
	if(defined $time) {
	    $r->headers_out->set('Expires', &Apache::ASP::Date::time2str($time));
	} else {
	    confess("Response->ExpiresAbsolute(): date format $date not accepted");
	}
    }

    # do the Cache-Control header
    $r->headers_out->set('Cache-Control', $self->{CacheControl});

    # do PICS header
    defined($self->{PICS}) && $r->headers_out->set('PICS-Label', $self->{PICS});

    # don't send headers with filtering, since filter will do this for
    # all the modules once
    # doug sanctioned this one
    unless($r->headers_out->get("Content-type")) {
	# if filtering, we don't send out a header from ASP
	# this means that Filtered scripts can use CGI headers
	# we order the test this way in case Ken comes on
	# board with setting header_out, in which case the test
	# will fail early
	if(! $asp->{filter} && (! defined $status or $status >= 200 && $status < 400)) {
	    $dbg && $asp->Debug("sending cgi headers");
	    if(defined $self->{header_buffer}) {
		# we have taken in cgi headers
		$r->send_cgi_header($self->{header_buffer} . "\n");
		$self->{header_buffer} = undef;
	    } else {
		unless($Apache::ASP::ModPerl2) {
		    # don't need this for mod_perl2 it seems from Apache::compat
		    $r->send_http_header();
		}
	    }
	}
    }

    1;
}

# do cookies, try our best to emulate cookie collections
sub AddCookieHeaders {
    my $self = shift;
    my $cookies = $self->{'Cookies'};
    my $dbg = $self->{asp}{dbg};

#    print STDERR Data::Dumper::DumperX($cookies);

    my($cookie_name, $cookie);
    for $cookie_name (sort keys %{$cookies}) {
	# skip key used for session id
	if($Apache::ASP::SessionCookieName eq $cookie_name) {
	    confess("You can't use $cookie_name for a cookie name ".
		    "since it is reserved for session management"
		    );
	}

	my($k, $v, @data, $header, %dict, $is_ref, $cookie, $old_k);

	$cookie = $cookies->{$cookie_name};
	unless(ref $cookie) {
	    $cookie->{Value} = $cookie;
	}
	$cookie->{Path} ||= '/';

	for $k (sort keys %$cookie) {
	    $v = $cookie->{$k};
	    $old_k = $k;
	    $k = lc $k;

#	    print STDERR "$k ---> $v\n\n";

	    if($k eq 'secure' and $v) {
		$data[4] = 'secure';
	    } elsif($k eq 'domain') {
		$data[3] = "$k=$v";
	    } elsif($k eq 'value') {
		# we set the value later, nothing for now
	    } elsif($k eq 'expires') {
		my $time;
		# only the date form of expires is portable, the
		# time vals are nice features of this implementation
		if($v =~ /^\-?\d+$/) {
		    # if expires is a perl time val
		    if($v > time()) {
			# if greater than time now, it is absolute
			$time = $v;
		    } else {
			# small, relative time, add to time now
			$time = $v + time();
		    }
		} else {
		    # it is a string format, PORTABLE use
		    $time = &Apache::ASP::Date::str2time($v);
		}

		my $date = &Apache::ASP::Date::time2str($time);
		$dbg && $self->{asp}->Debug("setting cookie expires",
					    {from => $v, to=> $date}
					   );
		$v = $date;
		$data[1] = "$k=$v";
	    } elsif($k eq 'path') {
		$data[2] = "$k=$v";
	    } else {
		if(defined($cookie->{Value}) && ! (ref $cookie->{Value})) {
		    # if the cookie value is just a string, its not a dict
		} else {
		    # cookie value is a dict, add to it
		    $cookie->{Value}{$old_k} = $v;
		}
	    }
	}

	my $server = $self->{asp}{Server}; # for the URLEncode routine
	if(defined($cookie->{Value}) && (! ref $cookie->{Value})) {
	    $cookie->{Value} = $server->URLEncode($cookie->{Value});
	} else {
	    my @dict;
	    for my $k ( sort keys %{$cookie->{Value}} ) {
		my $v = $cookie->{Value}{$k};
		push(@dict, $server->URLEncode($k) . '=' . $server->URLEncode($v));
	    }
	    $cookie->{Value} = join('&', @dict);
	}
	$data[0] = $server->URLEncode($cookie_name) . "=$cookie->{Value}";

	# have to clean the data now of undefined values, but
	# keeping the position is important to stick to the Cookie-Spec
	my @cookie;
	for(0..4) {
	    next unless $data[$_];
	    push(@cookie, $data[$_]);
	}
	my $cookie_header = join('; ', @cookie);

	$self->{r}->err_headers_out->add('Set-Cookie', $cookie_header);
	$dbg && $self->{asp}->Debug({cookie_header=>$cookie_header});
    }
}

# with the WriteRef vs. Write abstration, direct calls
# to write might slow a little, but more common static
# html calls to WriteRef will be saved the HTML copy
sub Write {
    my $self = shift;

    my $dataref;
    if(@_ > 1) {
	$, ||= ''; # non-standard use, so init here
	my $data = join($,, @_);
	$dataref = \$data;
    } else {
#	$_[0] ||= '';
	$dataref = defined($_[0]) ? \$_[0] : \'';
    }

    &WriteRef($self, $dataref);

    1;
}

# \'';

*Apache::ASP::WriteRef = *WriteRef;
sub WriteRef {
    my($self, $dataref) = @_;

    # allows us to end a response, but still execute code in event
    # handlers which might have output like Script_OnStart / Script_OnEnd
    return if $self->{Ended};
#    my $content_out = $self->{out};

    if($self->{CH}) {
	# CgiHeaders may change the reference to the dataref, because
	# dataref is a read-only scalar ref of static data, and CgiHeaders
	# may need to change it
	$dataref = $self->CgiHeaders($dataref);
    }

    # add dataref to buffer
    ${$self->{out}} .= $$dataref;

    # do we flush now?  not if we are buffering
    if(! $self->{'Buffer'} && ! $self->{'FormFill'}) {
	# we test for whether anything is in the buffer since
	# this way we can keep reading headers before flushing
	# them out
	&Flush($self);
    }

    1;
}
*write = *Write;

# alias printing to the response object
sub TIEHANDLE { $_[1]; }
*PRINT = *Write;
sub PRINTF {
    my($self, $format, @list) = @_;
    my $output = sprintf($format, @list);
    $self->WriteRef(\$output);
}

sub CgiHeaders {
    my($self, $dataref) = @_;
    my $content_out = $self->{out};

    # work on the headers while the header hasn't been done
    # and while we don't have anything in the buffer yet
    #
    # also added a test for the content type being text/html or
    #
    if($self->{CH} && ! $self->{header_done} && ! $$content_out
       && ($self->{ContentType} =~ /$TextHTMLRegexp/o))
      {
	  # -1 to catch the null at the end maybe
	  my @headers = split(/\n/, $$dataref, -1);

	  # first do status line
	  my $status = $headers[0];
	  if($status =~ m|HTTP/\d\.\d\s*(\d*)|o) {
	      $self->{Status} = $1;
	      shift @headers;
	  }

	  while(@headers) {
	      my $out = shift @headers;
	      next unless $out; # skip the blank that comes after the last newline

	      if($out =~ /^[^\s]+\: /) { # we are a header
		  unless(defined $self->{header_buffer}) {
		      $self->{header_buffer} .= '';
		  }
		  $self->{header_buffer} .= "$out\n";
	      } else {
		  unshift(@headers, $out);
		  last;
	      }
	  }

	  # take remaining non-headers & set the data to them joined back up
	  my $data_left = join("\n", @headers);
	  $dataref = \$data_left;
      }

    $dataref;
}

sub Null {};
sub TrapInclude {
    my($self, $file) = (shift, shift);

    my $out = "";
    local $self->{out} = local $self->{BinaryRef} = \$out;
    local $self->{Ended} = 0;
    local *Apache::ASP::Response::Flush = *Null;
    $self->Include($file, @_);

    \$out;
}

sub Include {
    my $self = shift;
    my $file = shift;
    my $asp = $self->{asp};

    my($cache, $cache_key, $cache_expires, $cache_clear);
    if(ref($file) && ref($file) eq 'HASH') {
	my $data = $file;
	$file = $data->{File}
	  || $asp->Error("no File key passed to Include(), keys ".join(',', keys %$file));
	$asp->{dbg} && $asp->Debug("file $file from HASH ref in Include()");

	if($data->{Cache}) {
	    $cache = 1;
	    $cache_expires = $data->{'Expires'};
	    $cache_clear = $data->{'Clear'};
	    my $file_data = '';
	    if(ref($file)) {
		$file_data = 'INCLUDE SCALAR REF '.$$file;
	    } else {
		my $real_file = $asp->SearchDirs($file);
		$file_data = 'INCLUDE FILE '.(stat($real_file))[9].' //\\ :: '.$real_file.' //\\ :: '.$file;
	    }
	    if($data->{Key}) {
		$cache_key = $file_data .' //\\ :: '.DumperX($data->{Key});
		$asp->{dbg} && $asp->Debug("include cache key length ".length($cache_key)." with extra Key data");
	    } else {
		$asp->{dbg} && $asp->Debug("include cache key length ".length($file_data));
		$cache_key = $file_data;
	    }
	    $cache_key .= ' //\\ COMPILE CHECKSUM :: '.$asp->{compile_checksum};
	    $cache_key .= ' //\\ ARGS :: '.DumperX(@_);
	    if(! $cache_clear) {
		my $rv = $asp->Cache('Response', \$cache_key, undef, $data->{Expires}, $data->{LastModified});
		if($rv) {
		    if(! eval { ($rv->{RV} && $rv->{OUT}) }) {
			$asp->{dbg} && $self->Debug("cache item invalid: $@");
		    } else {
			$asp->{dbg} && $asp->Debug("found include $file output in cache");
			$self->WriteRef($rv->{OUT});
			my $rv_data = $rv->{RV};
			return wantarray ? @$rv_data : $rv_data->[0];
		    }
		}
	    }
	}
    }

    my $_CODE = $asp->CompileInclude($file);
    unless(defined $_CODE) {
	die("error including $file, not compiled: $@");
    }

    $asp->{last_compile_include_data} = $_CODE;
    my $eval = $_CODE->{code};

    # exit early for cached static file
    if(ref $eval eq 'SCALAR') {
       $asp->{dbg} && $asp->Debug("static file data cached, not compiled, length: ".length($$eval));
       $self->WriteRef($eval);
       return;
    }

    $asp->{dbg} && $asp->Debug("executing $eval");

    my @rc;
    if($cache) {
	my $out = "";
	{
	    local $self->{out} = local $self->{BinaryRef} = \$out;
	    local $self->{Ended} = 0;
	    local *Apache::ASP::Response::Flush = *Null;
	    @rc = eval { &$eval(@_) };
	    $asp->{dbg} && $asp->Debug("caching $file output expires: ".($cache_expires || ''));
	    $asp->Cache('Response', \$cache_key, { RV => [ @rc ], OUT => \$out }, $cache_expires);
	}
	$self->WriteRef(\$out);
    } else {
	@rc = eval { &$eval(@_) };
    }
    if($@) {
	my $code = $_CODE;
	die "error executing code for include $code->{file}: $@; compiled to $code->{perl}";
    }
    $asp->{dbg} && $asp->Debug("done executing include code $eval");

    wantarray ? @rc : $rc[0];
}

sub ErrorDocument {
    my($self, $error_code, $uri) = @_;
    $self->{'r'}->custom_response($error_code, $uri);
}

sub SessionQueryParse {
    my $self = shift;

    # OPTIMIZE MATCH: a is first in the sort, so this is fairly well optimized,
    # putting img up at the front doesn't seem to make a different in the speed
    my $tags_grep = join('|', sort keys %LinkTags);
    my $new_content = ''; # we are going to rebuild this content
    my $content_ref = $self->{out};
    my $asp = $self->{asp};
    $asp->{dbg} && $asp->Debug("parsing session id into url query strings");

    # update quoted links in script location.href settings too
    # if not quoted, then maybe script expressions
    $$content_ref =~
      s/(\[^\<]*location\.href\s*\=[\"\'])([^\"\']+?)([\"\'])
	/$1.&SessionQueryParseURL($self, $2).$3
	  /isgex;

    while(1) {
	# my emacs perl mode doesn't like ${$doc->{content}}
	last unless ($$content_ref =~ s/
		     ^(.*?)               # html head
		     \<                   # start
		     \s*($tags_grep)\s+  # tag itself
		     ([^>]+)              # descriptors
		     \>                   # end
		     //isxo
		     );

	my($head, $tag, $temp_attribs) = ($1, lc($2), $3);
	my $element = "<$2 $temp_attribs>";
	my %attribs;

	while($temp_attribs =~ s/^\s*([^\s=]+)\s*\=?//so) {
	    my $key = lc $1;
	    my $value;
	    if($temp_attribs =~ s/^\s*\"([^\"]*)\"\s*//so) {
		$value = $1;
	    } elsif ($temp_attribs =~ s/^\s*\'([^\']*)\'\s*//so) {
		# apparently browsers support single quoting values
		$value = $1;
	    } elsif($temp_attribs =~ s/^\s*([^\s]*)\s*//so) {
		# sometimes there are mal-formed URL's
		$value = $1;
		$value =~ s/\"//sgo;
	    }
	    $attribs{$key} = $value;
	}

	# GET URL from tag attribs finally
	my $rel_url = $attribs{$LinkTags{$tag}};
#	$asp->Debug($rel_url, $element, \%attribs);
	if(defined $rel_url) {
	    my $new_url = &SessionQueryParseURL($self, $rel_url);
	    # escape all special characters so they are not interpreted
	    if($new_url ne $rel_url) {
		$rel_url =~ s/([\W])/\\$1/sg;
		$element =~ s|($LinkTags{$tag}\s*\=\s*[\"\']?)$rel_url|$1$new_url|isg;
#		$asp->Debug("parsed new element $element");
	    }
	}

	$new_content .= $head . $element;
    }

#    $asp->Debug($$content_ref);
    $new_content .= $$content_ref;
    $$content_ref = $new_content;
    1;
}

sub SessionQueryParseURL {
    my($self, $rel_url) = @_;
    my $asp = $self->{asp};
    my $match = $asp->{session_url_parse_match};

    if(
       # if we have match expression, try it
       ($match && $rel_url =~ /$match/)
       # then if server path, check matches cookie space
       || ($rel_url =~ m|^/| and $rel_url =~ m|^$asp->{cookie_path}|)
       # then do all local paths, matching NOT some URI PROTO
       || ($rel_url !~ m|^[^\?\/]+?:|)
      )
      {
	  my($query, $new_url, $frag);
	  if($rel_url =~ /^([^\?]+)(\?([^\#]*))?(\#.*)?$/) {
              $new_url = $1;
              $query = defined $3 ? $3 : '';
	      $frag = $4;
	  } else {
	      $new_url = $rel_url;
	      $query = '';
	  }

	  # for the split, we do not need to handle other entity references besides &
	  # because &, =, and ; should be the only special characters in the query string
	  # and the only of these characters that are represented by an entity reference
	  # is & as & ... the rest of the special characters that might be encoded
	  # in a URL should be URI escaped
	  # --jc 2/10/2003
	  my @new_query_parts;
	  map {
	      (! /^$Apache::ASP::SessionCookieName\=/) && push(@new_query_parts, $_);
	  }
	    split(/&|&/, $query);

	  my $new_query = join('&',
			       @new_query_parts,
			       $Apache::ASP::SessionCookieName.'='.$asp->{session_id}
			      );
	  $new_url .= '?'.$new_query;
	  if($frag) {
	      $new_url .= $frag;
	  }
	  $asp->{dbg} && $asp->Debug("parsed session into $new_url");
	  $new_url;
      } else {
	  $rel_url;
      }
}

*config = *Apache::ASP::config;

1;