536 lines
12 KiB
Perl
536 lines
12 KiB
Perl
package WebGUI::Session::Http;
|
|
|
|
=head1 LEGAL
|
|
|
|
-------------------------------------------------------------------
|
|
WebGUI is Copyright 2001-2006 Plain Black Corporation.
|
|
-------------------------------------------------------------------
|
|
Please read the legal notices (docs/legal.txt) and the license
|
|
(docs/license.txt) that came with this distribution before using
|
|
this software.
|
|
-------------------------------------------------------------------
|
|
http://www.plainblack.com info@plainblack.com
|
|
-------------------------------------------------------------------
|
|
|
|
=cut
|
|
|
|
|
|
use strict;
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::Session::Http
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This package allows the manipulation of HTTP protocol information.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use WebGUI::Session::Http;
|
|
|
|
my $http = WebGUI::Session::Http->new($session);
|
|
|
|
$http->sendHeader();
|
|
|
|
$cookies = $http->getCookies();
|
|
$mimetype = $http->getMimeType();
|
|
$code = $http->getStatus();
|
|
($code, $description) = $http->getStatus();
|
|
$description = $http->getStatusDescription();
|
|
$boolean = $http->isRedirect();
|
|
|
|
$http->setCookie($name,$value);
|
|
$http->setFilename($filename,$mimetype);
|
|
$http->setMimeType($mimetype);
|
|
$http->setNoHeader($bool);
|
|
$http->setRedirect($url);
|
|
|
|
=head1 METHODS
|
|
|
|
These methods are available from this package:
|
|
|
|
=cut
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 DESTROY ( )
|
|
|
|
Deconstructor.
|
|
|
|
=cut
|
|
|
|
sub DESTROY {
|
|
my $self = shift;
|
|
undef $self;
|
|
}
|
|
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getCacheControl ( )
|
|
|
|
Returns the cache control setting from this object.
|
|
|
|
=cut
|
|
|
|
sub getCacheControl {
|
|
my $self = shift;
|
|
return $self->{_http}{cacheControl};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getCookies ( )
|
|
|
|
Retrieves the cookies from the HTTP header and returns a hash reference containing them.
|
|
|
|
=cut
|
|
|
|
sub getCookies {
|
|
my $self = shift;
|
|
if ($self->session->request) {
|
|
# Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows)
|
|
require APR::Request::Apache2;
|
|
my $jarHashRef = APR::Request::Apache2->handle($self->session->request)->jar();
|
|
return $jarHashRef if $jarHashRef;
|
|
return {};
|
|
}
|
|
else {
|
|
return {};
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getLastModified ( )
|
|
|
|
Returns the stored epoch date when the page as last modified.
|
|
|
|
=cut
|
|
|
|
sub getLastModified {
|
|
my $self = shift;
|
|
return $self->{_http}{lastModified};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getMimeType ( )
|
|
|
|
Returns the current mime type of the document to be returned.
|
|
|
|
=cut
|
|
|
|
sub getMimeType {
|
|
my $self = shift;
|
|
return $self->{_http}{mimetype} || "text/html; charset=UTF-8";
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getNoHeader ( )
|
|
|
|
Returns whether or not a HTTP header will be printed.
|
|
|
|
=cut
|
|
|
|
sub getNoHeader {
|
|
my $self = shift;
|
|
return $self->{_http}{noHeader};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getRedirectLocation ( )
|
|
|
|
Return the location that was set via setRedirect
|
|
|
|
=cut
|
|
|
|
sub getRedirectLocation {
|
|
my $self = shift;
|
|
return $self->{_http}{location};
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getStatus ( ) {
|
|
|
|
Returns the current HTTP status code. If no code has been set,
|
|
the code returned will be 200. If no description has been set,
|
|
the internal description will be set to "OK" and "OK" will be returned.
|
|
|
|
=cut
|
|
|
|
sub getStatus {
|
|
my $self = shift;
|
|
$self->{_http}{statusDescription} = $self->{_http}{statusDescription} || "OK";
|
|
my $status = $self->{_http}{status} || "200";
|
|
return $status;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getStatusDescription ( ) {
|
|
|
|
Returns the current HTTP status description. If no description has
|
|
been set, "OK" will be returned.
|
|
|
|
=cut
|
|
|
|
sub getStatusDescription {
|
|
my $self = shift;
|
|
return $self->{_http}{statusDescription} || "OK";
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getStreamedFile ( ) {
|
|
|
|
Returns the location of a file to be streamed thru mod_perl, if one has been set.
|
|
|
|
=cut
|
|
|
|
sub getStreamedFile {
|
|
my $self = shift;
|
|
return $self->{_http}{streamlocation} || undef;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 isRedirect ( )
|
|
|
|
Returns a boolean value indicating whether the current page will redirect to some other location.
|
|
|
|
=cut
|
|
|
|
sub isRedirect {
|
|
my $self = shift;
|
|
return ($self->getStatus() eq "302");
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 new ( session )
|
|
|
|
Constructor.
|
|
|
|
=head3 session
|
|
|
|
A reference to the current session.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $session = shift;
|
|
bless {_session=>$session}, $class;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 sendHeader ( )
|
|
|
|
Generates and sends HTTP headers for a response.
|
|
|
|
=cut
|
|
|
|
sub sendHeader {
|
|
my $self = shift;
|
|
return undef if ($self->{_http}{noHeader});
|
|
return $self->_sendMinimalHeader if $self->session->dbNotAvailable;
|
|
|
|
my ($request, $datetime, $config, $var) = $self->session->quick(qw(request datetime config var));
|
|
return undef unless $request;
|
|
my $userId = $var->get("userId");
|
|
|
|
# send webgui session cookie
|
|
my $cookieName = $config->getCookieName;
|
|
$self->setCookie($cookieName,$var->getId, $config->getCookieTTL, $config->get("cookieDomain")) unless $var->getId eq $self->getCookies->{$cookieName};
|
|
|
|
$self->setNoHeader(1);
|
|
my %params;
|
|
if ($self->isRedirect()) {
|
|
$request->headers_out->set(Location => $self->getRedirectLocation);
|
|
$request->status(301);
|
|
} else {
|
|
$request->content_type($self->getMimeType || "text/html; charset=UTF-8");
|
|
my $cacheControl = $self->getCacheControl;
|
|
my $date = ($userId eq "1") ? $datetime->epochToHttp($self->getLastModified) : $datetime->epochToHttp;
|
|
$request->headers_out->set('Last-Modified' => $date);
|
|
if ($cacheControl eq "none" || $self->session->setting->get("preventProxyCache") || ($cacheControl eq "" && $userId ne "1")) {
|
|
$request->headers_out->set("Cache-Control" => "private");
|
|
$request->no_cache(1);
|
|
} elsif ($cacheControl ne "" && $request->protocol =~ /(\d\.\d)/ && $1 >= 1.1){
|
|
my $extras = "";
|
|
$extras .= ", private" unless ($userId eq "1");
|
|
$request->headers_out->set('Cache-Control' => "max-age=" . $cacheControl.$extras);
|
|
} elsif ($cacheControl ne "") {
|
|
$request->headers_out->set("Cache-Control" => "private") unless ($userId eq "1");
|
|
my $date = $datetime->epochToHttp(time() + $cacheControl);
|
|
$request->headers_out->set('Expires' => $date);
|
|
}
|
|
if ($self->getFilename) {
|
|
$request->headers_out->set('Content-Disposition' => qq!attachment; filename="!.$self->getFilename().'"');
|
|
}
|
|
$request->status($self->getStatus());
|
|
$request->status_line($self->getStatus().' '.$self->getStatusDescription());
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _sendMinimalHeader {
|
|
my $self = shift;
|
|
my $request = $self->session->request;
|
|
$request->content_type('text/html; charset=UTF-8');
|
|
$request->headers_out->set('Cache-Control' => 'private');
|
|
$request->no_cache(1);
|
|
$request->status($self->getStatus());
|
|
$request->status_line($self->getStatus().' '.$self->getStatusDescription());
|
|
return;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 session ( )
|
|
|
|
Returns the reference to the current session.
|
|
|
|
=cut
|
|
|
|
sub session {
|
|
my $self = shift;
|
|
return $self->{_session};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setCacheControl ( timeout )
|
|
|
|
Sets the cache control headers.
|
|
|
|
=head3 timeout
|
|
|
|
Either the number of seconds until the cache expires, or the word "none" to disable cache completely for this request.
|
|
|
|
=cut
|
|
|
|
sub setCacheControl {
|
|
my $self = shift;
|
|
my $timeout = shift;
|
|
$self->{_http}{cacheControl} = $timeout;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setCookie ( name, value [ , timeToLive, domain ] )
|
|
|
|
Sends a cookie to the browser.
|
|
|
|
=head3 name
|
|
|
|
The name of the cookie to set. Must be unique from all other cookies from this domain or it will overwrite that cookie.
|
|
|
|
=head3 value
|
|
|
|
The value to set.
|
|
|
|
=head3 timeToLive
|
|
|
|
The time that the cookie should remain in the browser. Defaults to "+10y" (10 years from now).
|
|
This may be "session" to indicate that the cookie is for the current browser session only.
|
|
|
|
=head3 domain
|
|
|
|
Explicitly set the domain for this cookie.
|
|
|
|
=cut
|
|
|
|
sub setCookie {
|
|
my $self = shift;
|
|
my $name = shift;
|
|
my $value = shift;
|
|
my $ttl = shift;
|
|
my $domain = shift;
|
|
$ttl = (defined $ttl ? $ttl : '+10y');
|
|
|
|
if ($self->session->request) {
|
|
require Apache2::Cookie;
|
|
my $cookie = Apache2::Cookie->new($self->session->request,
|
|
-name=>$name,
|
|
-value=>$value,
|
|
-path=>'/'
|
|
);
|
|
|
|
$cookie->expires($ttl) if $ttl ne 'session';
|
|
$cookie->domain($domain) if ($domain);
|
|
$cookie->bake($self->session->request);
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setFilename ( filename [, mimetype] )
|
|
|
|
Override the default filename for the document, which is usually the page url. Usually used with setMimeType().
|
|
|
|
=head3 filename
|
|
|
|
The filename to set.
|
|
|
|
=head3 mimetype
|
|
|
|
The mimetype for this file. Defaults to "application/octet-stream".
|
|
|
|
=cut
|
|
|
|
sub setFilename {
|
|
my $self = shift;
|
|
$self->{_http}{filename} = shift;
|
|
my $mimetype = shift || "application/octet-stream";
|
|
$self->setMimeType($mimetype);
|
|
}
|
|
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getFilename ( )
|
|
|
|
Returns the default filename for the document.
|
|
|
|
=cut
|
|
|
|
sub getFilename {
|
|
my $self = shift;
|
|
return $self->{_http}{filename};
|
|
}
|
|
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setLastModified ( epoch )
|
|
|
|
=head3 epoch
|
|
|
|
The epoch date when the page was last modified.
|
|
|
|
=cut
|
|
|
|
sub setLastModified {
|
|
my $self = shift;
|
|
my $epoch = shift;
|
|
$self->{_http}{lastModified} = $epoch;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setMimeType ( mimetype )
|
|
|
|
Override mime type for the document, which is defaultly "text/html". Also see setFilename().
|
|
|
|
B<NOTE:> By setting the mime type to something other than "text/html" WebGUI will automatically not process the normal page contents. Instead it will return only the content of your Wobject function or Operation.
|
|
|
|
=head3 mimetype
|
|
|
|
The mime type for the document.
|
|
|
|
=cut
|
|
|
|
sub setMimeType {
|
|
my $self = shift;
|
|
$self->{_http}{mimetype} = shift;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setNoHeader ( boolean )
|
|
|
|
Disables the printing of a HTTP header. Useful in situations when content is not
|
|
returned to a browser (export to disk for example).
|
|
|
|
=head3 boolean
|
|
|
|
Any value other than 0 will disable header printing.
|
|
|
|
=cut
|
|
|
|
sub setNoHeader {
|
|
my $self = shift;
|
|
$self->{_http}{noHeader} = shift;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setRedirect ( url )
|
|
|
|
Sets the necessary information in the HTTP header to redirect to another URL.
|
|
|
|
=head3 url
|
|
|
|
The URL to redirect to.
|
|
|
|
=cut
|
|
|
|
sub setRedirect {
|
|
my $self = shift;
|
|
my $url = shift;
|
|
my @params = $self->session->form->param;
|
|
return undef if ($url eq $self->session->url->page() && scalar(@params) < 1); # prevent redirecting to self
|
|
$self->session->errorHandler->info("Redirecting to $url");
|
|
$self->{_http}{location} = $url;
|
|
$self->setStatus("302", "Redirect");
|
|
$self->session->style->setMeta({"http-equiv"=>"refresh",content=>"0; URL=".$url});
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setStatus ( code, description )
|
|
|
|
Sets the HTTP status code.
|
|
|
|
=head3 code
|
|
|
|
An HTTP status code. It is a 3 digit status number.
|
|
|
|
=head3 description
|
|
|
|
An HTTP status code description. It is a little one line of text that describes the status code.
|
|
|
|
=cut
|
|
|
|
sub setStatus {
|
|
my $self = shift;
|
|
$self->{_http}{status} = shift;
|
|
$self->{_http}{statusDescription} = shift;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setStreamedFile ( ) {
|
|
|
|
Set a file to be streamed thru mod_perl.
|
|
|
|
=cut
|
|
|
|
sub setStreamedFile {
|
|
my $self = shift;
|
|
$self->{_http}{streamlocation} = shift;
|
|
}
|
|
|
|
|
|
1;
|
|
|