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 ".

lib/Apache/ASP/Response.pm  view on Meta::CPAN

    }

    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