more session stuff
This commit is contained in:
JT Smith
parent
d4b7f2ce59
commit
68ff4fdf6c
5 changed files with 0 additions and 0 deletions
387
lib/WebGUI/Session/ErrorHandler.pm
Normal file
387
lib/WebGUI/Session/ErrorHandler.pm
Normal file
|
|
@ -0,0 +1,387 @@
|
|||
package WebGUI::ErrorHandler;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2005 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;
|
||||
use Log::Log4perl;
|
||||
use Apache2::RequestUtil;
|
||||
|
||||
$Log::Log4perl::caller_depth++;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::ErrorHandler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package provides simple but effective error handling, debugging, and logging for WebGUI.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::ErrorHandler;
|
||||
|
||||
my $errorHandler = WebGUI::ErrorHandler->new($session);
|
||||
|
||||
$errorHandler->audit($message);
|
||||
$errorHandler->debug($message);
|
||||
$errorHandler->error($message);
|
||||
$errorHandler->fatal($message);
|
||||
$errorHandler->info($message);
|
||||
$errorHandler->security($message);
|
||||
$errorHandler->warn($message);
|
||||
|
||||
$logger = $errorHandler->getLogger;
|
||||
|
||||
$text = $errorHandler->getSessionVars;
|
||||
$text = $errorHandler->getStackTrace;
|
||||
$html = $errorHandler->showDebug;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 audit ( message )
|
||||
|
||||
A convenience function that wraps info() and includes the current username and user ID in addition to the message being logged.
|
||||
|
||||
=head3 message
|
||||
|
||||
Whatever message you wish to insert into the log.
|
||||
|
||||
=cut
|
||||
|
||||
sub audit {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
$Log::Log4perl::caller_depth++;
|
||||
$self->info($self->{_session}->user->username." (".$self->{_session}->user->userId.") ".$message);
|
||||
$Log::Log4perl::caller_depth--;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canShowDebug ( )
|
||||
|
||||
Returns true if the user meets the condition to see debugging information and debug mode is enabled.
|
||||
|
||||
=cut
|
||||
|
||||
sub canShowDebug {
|
||||
my $self = shift;
|
||||
return 0 unless ($self->{_session}->setting->get("showDebug"));
|
||||
return 1 if ($self->{_session}->setting->get("debugIp") eq "");
|
||||
my @ips = split(" ",$self->{_session}->setting->get("debugIp"));
|
||||
my $ok = 0;
|
||||
foreach my $ip (@ips) {
|
||||
if ($self->{_session}->env("REMOTE_ADDR") =~ /^$ip/) {
|
||||
$ok = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canShowPerformanceIndicators ()
|
||||
|
||||
Returns true if the user meets the conditions to see performance indicators and performance indicators are enabled.
|
||||
|
||||
=cut
|
||||
|
||||
sub canShowPerformanceIndicators {
|
||||
my $self = shift;
|
||||
my $mask = $self->{_session}->setting->get("debugIp");
|
||||
my $ip = $self->{_session}->env("REMOTE_ADDR");
|
||||
return (
|
||||
(
|
||||
$self->{_session}->setting->get("showPerformanceIndicators")
|
||||
) && (
|
||||
$ip =~ /^$mask/ ||
|
||||
$self->{_session}->setting->get("debugIp") eq ""
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 debug ( message )
|
||||
|
||||
Adds a DEBUG type message to the log. These events should be things that are only used for diagnostic purposes.
|
||||
|
||||
=head3 message
|
||||
|
||||
The message you wish to add to the log.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
$self->getLogger->debug($message);
|
||||
$self->{_session}->stow->set("debug_debug") = $self->{_session}->stow->get("debug_debug").$message."\n";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 error ( message )
|
||||
|
||||
Adds a ERROR type message to the log. These events should be things that are errors that are not fatal. For instance, a non-compiling plug-in or erroneous user input.
|
||||
|
||||
=head3 message
|
||||
|
||||
The message you wish to add to the log.
|
||||
|
||||
=cut
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
$self->getLogger->error($message);
|
||||
$self->getLogger->debug("Stack trace for ERROR ".$message."\n".$self->getStackTrace());
|
||||
$self->{_session}->stow->set("debug_error") = $self->{_session}->stow->get("debug_error").$message."\n";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 fatal ( )
|
||||
|
||||
Adds a FATAL type message to the log, outputs an error message to the user, and forces a close on the session. This should only be called if the system cannot recover from an error, or it would be unsafe to recover from an error like database connectivity problems.
|
||||
|
||||
=cut
|
||||
|
||||
sub fatal {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $self->{_session}->http->setStatus("500","Server Error");
|
||||
Apache2::RequestUtil->request->content_type('text/html') if ($self->{_session}->request);
|
||||
$self->getLogger->fatal($message);
|
||||
$self->getLogger->debug("Stack trace for FATAL ".$message."\n".$self->getStackTrace());
|
||||
print $self->{_session}->http->getHeader if ($self->{_session}->request);
|
||||
unless ($self->canShowDebug()) {
|
||||
#NOTE: You can't internationalize this because with some types of errors that would cause an infinite loop.
|
||||
print "<h1>Problem With Request</h1>
|
||||
We have encountered a problem with your request. Please use your back button and try again.
|
||||
If this problem persists, please contact us with what you were trying to do and the time and date of the problem.";
|
||||
print '<br />'.$self->{_session}->setting("companyName");
|
||||
print '<br />'.$self->{_session}->setting("companyEmail");
|
||||
print '<br />'.$self->{_session}->setting("companyURL");
|
||||
} else {
|
||||
print "<h1>WebGUI Fatal Error</h1><p>Something unexpected happened that caused this system to fault.</p>\n";
|
||||
print "<p>".$message."</p>\n";
|
||||
print $self->showDebug();
|
||||
}
|
||||
$self->{_session}->close();
|
||||
die $message;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLogger ( )
|
||||
|
||||
Returns a reference to the logger.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLogger {
|
||||
my $self = shift;
|
||||
return $self->{_logger};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getSessionVars ( )
|
||||
|
||||
Returns a text message containing all of the session variables.
|
||||
|
||||
=cut
|
||||
|
||||
sub getSessionVars {
|
||||
my $self = shift;
|
||||
my $data;
|
||||
while (my ($section, $hash) = each %{$self->{_session}}) {
|
||||
if (ref $hash eq 'HASH') {
|
||||
while (my ($key, $value) = each %$hash) {
|
||||
if (ref $value eq 'ARRAY') {
|
||||
$value = '['.join(', ',@$value).']';
|
||||
} elsif (ref $value eq 'HASH') {
|
||||
$value = '{'.join(', ',map {"$_ => $value->{$_}"} keys %$value).'}';
|
||||
}
|
||||
unless (lc($key) eq "password" || lc($key) eq "identifier" || lc($key) eq "dbpass") {
|
||||
$data .= "\t".$section.'.'.$key.' = '.$value."\n";
|
||||
}
|
||||
}
|
||||
} elsif (ref $hash eq 'ARRAY') {
|
||||
my $i = 1;
|
||||
foreach (@$hash) {
|
||||
$data .= "\t".$section.'.'.$i.' = '.$_."\n";
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
}
|
||||
return $data;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getStackTrace ( )
|
||||
|
||||
Returns a text formatted message containing the current stack trace.
|
||||
|
||||
=cut
|
||||
|
||||
sub getStackTrace {
|
||||
my $self = shift;
|
||||
my $i = 2;
|
||||
my $output;
|
||||
while (my @data = caller($i)) {
|
||||
$output .= "\t".join(",",@data)."\n";
|
||||
$i++;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 info ( message )
|
||||
|
||||
Adds an INFO type message to the log. This should be used for informational or status types of messages, such as audit information and FYIs.
|
||||
|
||||
=head3 message
|
||||
|
||||
The message you wish to add to the log.
|
||||
|
||||
=cut
|
||||
|
||||
sub info {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
$self->getLogger->info($message);
|
||||
$self->{_session}->stow->set("debug_info") = $self->{_session}->stow->get("debug_info").$message."\n";
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor. Instanciates a new error handler instance.
|
||||
|
||||
=head3 session
|
||||
|
||||
An active WebGUI::Session object.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
unless (Log::Log4perl->initialized()) {
|
||||
Log::Log4perl->init( $session->config->getWebguiRoot."/etc/log.conf" );
|
||||
}
|
||||
my $logger = Log::Log4perl->get_logger($session->config->getFilename);
|
||||
bless {_logger=>$logger, _session=>$session}, $class;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 security ( message )
|
||||
|
||||
A convenience function that wraps warn() and includes the current username, user ID, and IP address in addition to the message being logged.
|
||||
|
||||
=head3 message
|
||||
|
||||
The message you wish to add to the log.
|
||||
|
||||
=cut
|
||||
|
||||
sub security {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
$Log::Log4perl::caller_depth++;
|
||||
$self->warn($self->{_session}->user->username." (".$self->{_session}->user->userId.") connecting from "
|
||||
.$self->{_session}->env("REMOTE_ADDR")." attempted to ".$message);
|
||||
$log::Log4perl::caller_depth--;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 showDebug ( )
|
||||
|
||||
Creates an HTML formatted string
|
||||
|
||||
=cut
|
||||
|
||||
sub showDebug {
|
||||
my $self = shift;
|
||||
my $text = $self->{_session}->stow->get('debug_error');
|
||||
$text =~ s/\n/\<br \/\>\n/g;
|
||||
my $output = 'beginDebug<br /><div style="background-color: #800000;color: #ffffff;">'.$text."</div>\n";
|
||||
$text = $self->{_session}->stow->get('debug_warn');
|
||||
$text =~ s/\n/\<br \/\>\n/g;
|
||||
$output .= '<div style="background-color: #ffdddd;color: #000000;">'.$text."</div>\n";
|
||||
$text = $self->{_session}->stow->get('debug_info');
|
||||
$text =~ s/\n/\<br \/\>\n/g;
|
||||
$output .= '<div style="background-color: #ffffdd;color: #000000;">'.$text."</div>\n";
|
||||
$text = $self->{_session}->stow->get('debug_debug');
|
||||
$text =~ s/\n/\<br \/\>\n/g;
|
||||
$output .= '<div style="background-color: #dddddd;color: #000000;">'.$text."</div>\n";
|
||||
$text = $self->getSessionVars();
|
||||
$text =~ s/\n/\<br \/\>\n/g;
|
||||
$output .= '<div style="background-color: #ffffff;color: #000000;">'.$text."</div>\n";
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 warn ( message )
|
||||
|
||||
Adds a WARN type message to the log. These events should be things that are potentially severe, but not errors, such as security attempts or ineffiency problems.
|
||||
|
||||
=head3 message
|
||||
|
||||
The message you wish to add to the log.
|
||||
|
||||
=cut
|
||||
|
||||
sub warn {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
$self->getLogger->warn($message);
|
||||
$self->{_session}->stow->set("debug_warn") = $self->{_session}->stow->get("debug_warn").$message."\n";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
142
lib/WebGUI/Session/Form.pm
Normal file
142
lib/WebGUI/Session/Form.pm
Normal file
|
|
@ -0,0 +1,142 @@
|
|||
package WebGUI::FormProcessor;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2005 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 qw(vars subs);
|
||||
use WebGUI::DateTime;
|
||||
use WebGUI::HTML;
|
||||
use WebGUI::Session;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::FormProcessor;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a convenience package to the individual form controls. It allows you to get the form post results back without having to load each form control seperately, instantiate an object, and call methods.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::FormProcessor;
|
||||
|
||||
my $fp = WebGUI::FormProcessor->new($session);
|
||||
|
||||
$value = $fp->process("favoriteColor", "selectList", "black");
|
||||
|
||||
$value = $fp->someFormControlType("fieldName");
|
||||
|
||||
Example:
|
||||
|
||||
$value = $fp->text("title");
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These functions are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 AUTOLOAD ()
|
||||
|
||||
Dynamically creates functions on the fly for all the different form control types.
|
||||
|
||||
=cut
|
||||
|
||||
sub AUTOLOAD {
|
||||
our $AUTOLOAD;
|
||||
my $self = shift;
|
||||
my $name = ucfirst((split /::/, $AUTOLOAD)[-1]);
|
||||
my $fieldName = shift;
|
||||
my $cmd = "use WebGUI::Form::".$name;
|
||||
eval ($cmd);
|
||||
if ($@) {
|
||||
$self->session->errorHandler->error("Couldn't compile form control: ".$name.". Root cause: ".$@);
|
||||
return undef;
|
||||
}
|
||||
my $class = "WebGUI::Form::".$name;
|
||||
return $class->new($self->session, {name=>$fieldName})->getValueFromPost;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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 process ( name, type [ , default ] )
|
||||
|
||||
Returns whatever would be the expected result of the method type that was specified. This method also checks to make sure that the field is not returning a string filled with nothing but whitespace.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the form variable to retrieve.
|
||||
|
||||
=head3 type
|
||||
|
||||
The type of form element this variable came from. Defaults to "text" if not specified.
|
||||
|
||||
=head3 default
|
||||
|
||||
The default value for this variable. If the variable is undefined then the default value will be returned instead.
|
||||
|
||||
=cut
|
||||
|
||||
sub process {
|
||||
my ($self, $name, $type, $default) = @_;
|
||||
my $value;
|
||||
$type = ucfirst($type);
|
||||
$type = "Text" if ($type eq "");
|
||||
$value = $self->$type($self->session,$name);
|
||||
unless (defined $value) {
|
||||
return $default;
|
||||
}
|
||||
if ($value =~ /^[\s]+$/) {
|
||||
return undef;
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session
|
||||
|
||||
=cut
|
||||
|
||||
sub session
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
321
lib/WebGUI/Session/Http.pm
Normal file
321
lib/WebGUI/Session/Http.pm
Normal file
|
|
@ -0,0 +1,321 @@
|
|||
package WebGUI::HTTP;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2005 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;
|
||||
use Apache2::Cookie;
|
||||
use APR::Request::Apache2;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::Style;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::HTTP
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package allows the manipulation of HTTP protocol information.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::HTTP;
|
||||
|
||||
my $http = WebGUI::HTTP->new($session);
|
||||
|
||||
$cookies = $http->getCookies();
|
||||
$header = $http->getHeader();
|
||||
$mimetype = $http->getMimeType();
|
||||
$code = $http->getStatus();
|
||||
$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 getCookies ( )
|
||||
|
||||
Retrieves the cookies from the HTTP header and returns a hash reference containing them.
|
||||
|
||||
=cut
|
||||
|
||||
sub getCookies {
|
||||
my $self = shift;
|
||||
return APR::Request::Apache2->handle($self->session->request)->jar();
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getHeader ( )
|
||||
|
||||
Generates an HTTP header.
|
||||
|
||||
=cut
|
||||
|
||||
sub getHeader {
|
||||
my $self = shift;
|
||||
return undef if ($self->{_http}{noHeader});
|
||||
my %params;
|
||||
if ($self->isRedirect()) {
|
||||
$self->session->request->headers_out->set(Location => $self->{_http}{location});
|
||||
$self->session->request->status(301);
|
||||
} else {
|
||||
$self->session->request->content_type($self->{_http}{mimetype} || "text/html");
|
||||
if ($self->session->setting->get("preventProxyCache")) {
|
||||
$params{"-expires"} = "-1d";
|
||||
}
|
||||
if ($session{http}{filename}) {
|
||||
$params{"-attachment"} = $self->{_http}{filename};
|
||||
}
|
||||
}
|
||||
$params{"-cookie"} = $self->{_http}{cookie};
|
||||
$self->session->request->status_line($self->getStatus().' '.$self->{_http}{statusDescription}) if $self->session->request;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getStatus ( ) {
|
||||
|
||||
Returns the current HTTP status code, if one has been set.
|
||||
|
||||
=cut
|
||||
|
||||
sub getStatus {
|
||||
my $self = shift;
|
||||
$self->{_http}{statusDescription} = $self->{_http}{statusDescription} || "OK";
|
||||
return $self->{_http}{status} || "200";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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 session ( )
|
||||
|
||||
Returns the reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setCookie ( name, value [ , timeToLive ] )
|
||||
|
||||
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).
|
||||
|
||||
=cut
|
||||
|
||||
sub setCookie {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
my $ttl = shift;
|
||||
$ttl = (defined $ttl ? $ttl : '+10y');
|
||||
if (exists $self->session->request) {
|
||||
my $cookie = Apache2::Cookie->new($self->session->request,
|
||||
-name=>$name,
|
||||
-value=>$value,
|
||||
# -domain=>'.'.$session{env}{HTTP_HOST},
|
||||
-expires=>$ttl,
|
||||
-path=>'/'
|
||||
);
|
||||
$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 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;
|
||||
$self->{_http}{location} = shift;
|
||||
$self->setStatus("302", "Redirect");
|
||||
$self->session->style->setMeta({"http-equiv"=>"refresh",content=>"0; URL=".$self->{_http}{location}});
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
171
lib/WebGUI/Session/Setting.pm
Normal file
171
lib/WebGUI/Session/Setting.pm
Normal file
|
|
@ -0,0 +1,171 @@
|
|||
package WebGUI::Setting;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2005 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;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::SQL;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Setting;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package stores and retrieves settings. It is generally only used internally by WebGUI and not by external scripts.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Setting;
|
||||
|
||||
$settings = WebGUI::Settings->new;
|
||||
|
||||
$settings->set($name, $value);
|
||||
$value = $settings->get($name);
|
||||
|
||||
$settings->add($name, $value);
|
||||
$settings->remove($name);
|
||||
|
||||
$session = $settings->session;
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 add ( name, value )
|
||||
|
||||
Creates a new setting.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the setting to add.
|
||||
|
||||
=head3 value
|
||||
|
||||
The initial value of the setting.
|
||||
|
||||
=cut
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
$self->{_settings}{$name} = $value;
|
||||
$self->session->db->write("insert into settings (name,value) values (".quote($name).",".quote($value).")");
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( )
|
||||
|
||||
Returns a hash reference containing all the settings.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
return $self->{_settings}{$param};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current WebGUI::Session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift
|
||||
my $session = shift;
|
||||
my $settings = $session->db->buildHashRef("select * from settings");
|
||||
bless {_settings=>$settings, _session=>$session}, $class;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 remove ( name )
|
||||
|
||||
Removes a setting permanently.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the setting to set.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
delete $self->{_settings}{$name};
|
||||
$self->session->db->write("delete from settings where name=".quote($name));
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the WebGUI::Session object.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 set ( name, value )
|
||||
|
||||
Sets the value of a setting.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the setting to set.
|
||||
|
||||
=head3 value
|
||||
|
||||
The value of the setting.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
$self->{_settings}{$name} = $value;
|
||||
$self->session->db->write("update settings set value=".quote($value)." where name=".quote($name));
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
330
lib/WebGUI/Session/Style.pm
Normal file
330
lib/WebGUI/Session/Style.pm
Normal file
|
|
@ -0,0 +1,330 @@
|
|||
package WebGUI::Style;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2005 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;
|
||||
use Tie::CPHash;
|
||||
use WebGUI::International;
|
||||
use WebGUI::Macro;
|
||||
use WebGUI::Asset::Template;
|
||||
use WebGUI::URL;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Style
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package contains utility methods for WebGUI's style system.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Style;
|
||||
$html = WebGUI::Style::process($content);
|
||||
|
||||
$html = generateAdditionalHeadTags();
|
||||
setLink($url,\%params);
|
||||
setMeta(\%params);
|
||||
setRawHeadTags($html);
|
||||
setScript($url, \%params);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 generateAdditionalHeadTags ( )
|
||||
|
||||
Creates tags that were set using setLink, setMeta, setScript, extraHeadTags, and setRawHeadTags.
|
||||
|
||||
=cut
|
||||
|
||||
sub generateAdditionalHeadTags {
|
||||
my $self = shift;
|
||||
# generate additional raw tags
|
||||
my $tags = $self->{_raw};
|
||||
# generate additional link tags
|
||||
foreach my $url (keys %{$self->{_link}}) {
|
||||
$tags .= '<link href="'.$url.'"';
|
||||
foreach my $name (keys %{$self->{_link}{$url}}) {
|
||||
$tags .= ' '.$name.'="'.$self->{_link}{$url}{$name}.'"';
|
||||
}
|
||||
$tags .= ' />'."\n";
|
||||
}
|
||||
# generate additional javascript tags
|
||||
foreach my $tag (@{$self->{_javascript}}) {
|
||||
$tags .= '<script';
|
||||
foreach my $name (keys %{$tag}) {
|
||||
$tags .= ' '.$name.'="'.$tag->{$name}.'"';
|
||||
}
|
||||
$tags .= '></script>'."\n";
|
||||
}
|
||||
# generate additional meta tags
|
||||
foreach my $tag (@{$self->{_meta}}) {
|
||||
$tags .= '<meta';
|
||||
foreach my $name (keys %{$tag}) {
|
||||
$tags .= ' '.$name.'="'.$tag->{$name}.'"';
|
||||
}
|
||||
$tags .= ' />'."\n";
|
||||
}
|
||||
# append extraHeadTags
|
||||
$tags .= $self->session->asset->getExtraHeadTags."\n" if ($self->session->asset);
|
||||
delete $self->{_meta};
|
||||
delete $self->{_raw};
|
||||
delete $self->{_javascript};
|
||||
delete $self->{_link};
|
||||
return $tags;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 makePrintable ( boolean )
|
||||
|
||||
Tells the system to use the make printable style instead of the normal style.
|
||||
|
||||
=head3 boolean
|
||||
|
||||
If set to 1 then the printable style will be used, otherwise the regular style will be used.
|
||||
|
||||
=cut
|
||||
|
||||
sub makePrintable {
|
||||
my $self = shift;
|
||||
$self->{_makePrintable} = shift;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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 process ( content, templateId )
|
||||
|
||||
Returns a parsed style with content based upon the current WebGUI session information.
|
||||
|
||||
=head3 content
|
||||
|
||||
The content to be parsed into the style. Usually generated by WebGUI::Page::generate().
|
||||
|
||||
=head3 templateId
|
||||
|
||||
The unique identifier for the template to retrieve.
|
||||
|
||||
=cut
|
||||
|
||||
sub process {
|
||||
my $self = shift;
|
||||
my %var;
|
||||
$var{'body.content'} = shift;
|
||||
my $templateId = shift;
|
||||
if ($self->{_makePrintable} && exists $self->session->asset) {
|
||||
$templateId = $self->session->asset->get("printableStyleTemplateId");
|
||||
my $currAsset = $self->session->asset;
|
||||
until ($templateId) {
|
||||
# some assets don't have this property. But at least one ancestor should....
|
||||
$currAsset = $currAsset->getParent;
|
||||
$templateId = $currAsset->get("printableStyleTemplateId");
|
||||
}
|
||||
} elsif ($self->session->scratch->get("personalStyleId") ne "") {
|
||||
$templateId = $self->session->scratch->get("personalStyleId");
|
||||
} elsif ($self->{_useEmptyStyle}) {
|
||||
$templateId = 6;
|
||||
}
|
||||
$var{'head.tags'} = '
|
||||
<meta name="generator" content="WebGUI '.$WebGUI::VERSION.'" />
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
|
||||
<meta http-equiv="Content-Script-Type" content="text/javascript" />
|
||||
<meta http-equiv="Content-Style-Type" content="text/css" />
|
||||
<script type="text/javascript">
|
||||
function getWebguiProperty (propName) {
|
||||
var props = new Array();
|
||||
props["extrasURL"] = "'.$self->session->config->get("extrasURL").'";
|
||||
props["pageURL"] = "'.WebGUI::URL::page(undef, undef, 1).'";
|
||||
return props[propName];
|
||||
}
|
||||
</script>
|
||||
';
|
||||
if (WebGUI::Grouping::isInGroup(2)) {
|
||||
# This "triple incantation" panders to the delicate tastes of various browsers for reliable cache suppression.
|
||||
$var{'head.tags'} .= '
|
||||
<meta http-equiv="Pragma" content="no-cache" />
|
||||
<meta http-equiv="Cache-Control" content="no-cache, must-revalidate, max-age=0" />
|
||||
<meta http-equiv="Expires" content="0" />
|
||||
';
|
||||
}
|
||||
$var{'head.tags'} .= "\n<!-- macro head tags -->\n";
|
||||
my $style = WebGUI::Asset::Template->new($templateId);
|
||||
my $output;
|
||||
if (defined $style) {
|
||||
$output = $style->process(\%var);
|
||||
} else {
|
||||
$output = "WebGUI was unable to instantiate your style template.".$var{'body.content'};
|
||||
}
|
||||
WebGUI::Macro::process(\$output);
|
||||
my $macroHeadTags = generateAdditionalHeadTags();
|
||||
WebGUI::Macro::process(\$macroHeadTags);
|
||||
$output =~ s/\<\!-- macro head tags --\>/$macroHeadTags/;
|
||||
if (WebGUI::ErrorHandler::canShowDebug()) {
|
||||
$output .= WebGUI::ErrorHandler::showDebug();
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setLink ( url, params )
|
||||
|
||||
Sets a <link> tag into the <head> of this rendered page for this page view. This is typically used for dynamically adding references to CSS and RSS documents.
|
||||
|
||||
=head3 url
|
||||
|
||||
The URL to the document you are linking.
|
||||
|
||||
=head3 params
|
||||
|
||||
A hash reference containing the other parameters to be included in the link tag, such as "rel" and "type".
|
||||
|
||||
=cut
|
||||
|
||||
sub setLink {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my $params = shift;
|
||||
$self->{_link}{$url} = $params;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setMeta ( params )
|
||||
|
||||
Sets a <meta> tag into the <head> of this rendered page for this page view.
|
||||
|
||||
=head3 params
|
||||
|
||||
A hash reference containing the parameters of the meta tag.
|
||||
|
||||
=cut
|
||||
|
||||
sub setMeta {
|
||||
my $self = shift;
|
||||
my $params = shift;
|
||||
push(@{$self->{_meta}},$params);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setRawHeadTags ( tags )
|
||||
|
||||
Sets data to be output into the <head> of the current rendered page for this page view.
|
||||
|
||||
=head3 tags
|
||||
|
||||
A raw string containing tags. This is just a raw string so you must actually pass in the full tag to use this call.
|
||||
|
||||
=cut
|
||||
|
||||
sub setRawHeadTags {
|
||||
my $self = shift;
|
||||
my $tags = shift;
|
||||
$self->{_raw} .= $tags;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setScript ( url, params )
|
||||
|
||||
Sets a <script> tag into the <head> of this rendered page for this page view. This is typically used for dynamically adding references to Javascript or ECMA script.
|
||||
|
||||
=head3 url
|
||||
|
||||
The URL to your script.
|
||||
|
||||
=head3 params
|
||||
|
||||
A hash reference containing the additional parameters to include in the script tag, such as "type" and "language".
|
||||
|
||||
=cut
|
||||
|
||||
sub setScript {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my $params = shift;
|
||||
$params->{src} = $url;
|
||||
my $found = 0;
|
||||
foreach my $script (@{$self->{_javascript}}) {
|
||||
$found = 1 if ($script->{src} eq $url);
|
||||
}
|
||||
push(@{$self->{_javascript}},$params) unless ($found);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 useEmptyStyle ( boolean )
|
||||
|
||||
Tells the style system to use an empty style rather than outputing the normal style. This is useful when you want your code to dynamically generate a style.
|
||||
|
||||
=head3 boolean
|
||||
|
||||
If set to 1 it will use an empty style, if set to 0 it will use the regular style. Defaults to 0.
|
||||
|
||||
=cut
|
||||
|
||||
sub useEmptyStyle {
|
||||
my $self = shift;
|
||||
$self->{_useEmptyStyle} = shift;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue