Apache-ASP
view release on metacpan or search on metacpan
lib/Apache/ASP/Response.pm view on Meta::CPAN
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) {
lib/Apache/ASP/Response.pm view on Meta::CPAN
# 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;
#Encode::_utf8_on(${$self->{out}});
#Encode::from_to(${$self->{out}}, "utf8", "iso-8859-1");
# 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;
}
lib/Apache/ASP/Response.pm view on Meta::CPAN
$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;
( run in 1.062 second using v1.01-cache-2.11-cpan-df04353d9ac )