Ready for 7.10.29 development.
This commit is contained in:
Colin Kuskie
commit
c806f99b7b
4236 changed files with 1217679 additions and 0 deletions
1000
lib/WebGUI/Session/DateTime.pm
Normal file
1000
lib/WebGUI/Session/DateTime.pm
Normal file
File diff suppressed because it is too large
Load diff
208
lib/WebGUI/Session/Env.pm
Normal file
208
lib/WebGUI/Session/Env.pm
Normal file
|
|
@ -0,0 +1,208 @@
|
|||
package WebGUI::Session::Env;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::Env
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package allows you to reference environment variables.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$env = WebGUI::Session::Env->new;
|
||||
|
||||
$value = $env->get('REMOTE_ADDR');
|
||||
|
||||
return 'not gonna see it' if $env->requestNotViewed() ;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 callerIsSearchSite ( )
|
||||
|
||||
Returns true if the remote address matches a site which is a known indexer or spider.
|
||||
|
||||
=cut
|
||||
|
||||
sub callerIsSearchSite {
|
||||
|
||||
my $self = shift;
|
||||
my $remoteAddress = $self->getIp;
|
||||
|
||||
return 1 if $remoteAddress =~ /203\.87\.123\.1../ # Blaiz Enterprise Rawgrunt search
|
||||
|| $remoteAddress =~ /123\.113\.184\.2../ # Unknown Yahoo Robot
|
||||
|| $remoteAddress == '';
|
||||
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 clientIsSpider ( )
|
||||
|
||||
Returns true is the client/agent is a spider/indexer or some other non-human interface, determined
|
||||
by checking the user agent against a list of known spiders.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub clientIsSpider {
|
||||
|
||||
my $self = shift;
|
||||
my $userAgent = $self->get('HTTP_USER_AGENT');
|
||||
|
||||
return 1 if $userAgent eq ''
|
||||
|| $userAgent =~ m<(^wre\/| # the WRE wget's http://localhost/ every 2-3 minutes 24 hours a day...
|
||||
^morpheus|
|
||||
libwww|
|
||||
s[pb]ider|
|
||||
bot|
|
||||
robo|
|
||||
sco[ou]t|
|
||||
crawl|
|
||||
miner|
|
||||
reaper|
|
||||
finder|
|
||||
search|
|
||||
engine|
|
||||
download|
|
||||
fetch|
|
||||
scan|
|
||||
slurp)>ix;
|
||||
|
||||
return 0;
|
||||
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( varName )
|
||||
|
||||
Retrieves the current value of an environment variable.
|
||||
|
||||
=head3 varName
|
||||
|
||||
The name of the variable.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
return $self->{_env}{$var};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getIp ( )
|
||||
|
||||
Returns the user's real IP address. Normally this is REMOTE_ADDR, but if they go through a proxy server it might be in HTTP_X_FORWARDED_FOR. This method attempts to figure out what the most likely IP is for the user. Note that it's possible to spoof this and therefore shouldn't be used as your only security mechanism for validating a user.
|
||||
|
||||
=cut
|
||||
|
||||
sub getIp {
|
||||
my $self = shift;
|
||||
if ($self->get("HTTP_X_FORWARDED_FOR") =~ m/(\d+\.\d+\.\d+\.\d+)/) {
|
||||
return $1;
|
||||
}
|
||||
return $self->get("REMOTE_ADDR");
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( )
|
||||
|
||||
Constructor. Returns an env object.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
bless {_env=>\%ENV}, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 requestNotViewed ( )
|
||||
|
||||
Returns true is the client/agent is a spider/indexer or some other non-human interface
|
||||
|
||||
=cut
|
||||
|
||||
sub requestNotViewed {
|
||||
|
||||
my $self = shift;
|
||||
return $self->clientIsSpider();
|
||||
# || $self->callerIsSearchSite(); # this part is currently left out because
|
||||
# it has minimal effect and does not manage
|
||||
# IPv6 addresses. it may be useful in the
|
||||
# future though
|
||||
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 sslRequest ( )
|
||||
|
||||
Returns true if a https request was made.
|
||||
|
||||
HTTP_SSLPROXY is set by mod_proxy in the WRE so that WebGUI knows that the original request
|
||||
was made via SSL.
|
||||
|
||||
=cut
|
||||
|
||||
sub sslRequest {
|
||||
my $self = shift;
|
||||
return (
|
||||
$self->get('HTTPS') eq 'on'
|
||||
|| $self->get('SSLPROXY')
|
||||
|| $self->get('HTTP_SSLPROXY')
|
||||
|| $self->get('HTTP_X_FORWARDED_PROTO') eq 'https'
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
489
lib/WebGUI/Session/ErrorHandler.pm
Normal file
489
lib/WebGUI/Session/ErrorHandler.pm
Normal file
|
|
@ -0,0 +1,489 @@
|
|||
package WebGUI::Session::ErrorHandler;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Scalar::Util qw( weaken );
|
||||
#use Apache2::RequestUtil;
|
||||
use JSON;
|
||||
use HTML::Entities qw(encode_entities);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::ErrorHandler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package provides simple but effective error handling, debugging, and logging for WebGUI.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Session::ErrorHandler;
|
||||
|
||||
my $errorHandler = WebGUI::Session::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->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;
|
||||
$self->info($self->session->user->username." (".$self->session->user->userId.") ".$message);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canShowBasedOnIP ( $ipSetting )
|
||||
|
||||
Returns true if the the user's IP address matches the requested IP setting.
|
||||
|
||||
=head3 ipSetting
|
||||
|
||||
The setting to pull from the database. It should containt a CSV list of IP
|
||||
addresses in CIDR format.
|
||||
|
||||
=cut
|
||||
|
||||
sub canShowBasedOnIP {
|
||||
my $self = shift;
|
||||
my $ipSetting = shift;
|
||||
return 0 unless $ipSetting;
|
||||
return 1 if ($self->session->setting->get($ipSetting) eq "");
|
||||
my $ips = $self->session->setting->get($ipSetting);
|
||||
$ips =~ s/\s+//g;
|
||||
my @ips = split(",", $ips);
|
||||
my $ok = WebGUI::Utility::isInSubnet($self->session->env->getIp, [ @ips] );
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canShowDebug ( )
|
||||
|
||||
Returns true if the user meets the condition to see debugging information and debug mode is enabled.
|
||||
This method caches its value, so long processes may need to manually clear the cached in $self->{_canShowDebug}.
|
||||
|
||||
=cut
|
||||
|
||||
sub canShowDebug {
|
||||
my $self = shift;
|
||||
|
||||
# if we have a cached false value, we can use it
|
||||
# true values need additional checks
|
||||
if (exists $self->{_canShowDebug} && !$self->{_canShowDebug}) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
##This check prevents in infinite loop during startup.
|
||||
return 0 unless ($self->session->hasSettings);
|
||||
|
||||
# Allow programmers to stop debugging output for certain requests
|
||||
return 0 if $self->{_preventDebugOutput};
|
||||
|
||||
my $canShow = $self->session->setting->get("showDebug")
|
||||
&& $self->canShowBasedOnIP('debugIp');
|
||||
$self->{_canShowDebug} = $canShow;
|
||||
|
||||
return $canShow
|
||||
&& substr($self->session->http->getMimeType(),0,9) eq "text/html";
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
return 0 unless $self->session->setting->get("showPerformanceIndicators");
|
||||
return $self->canShowBasedOnIP('debugIp');
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
return unless $self->canShowDebug || $self->getLogger->is_debug;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->debug($message);
|
||||
$self->{_debug_debug} .= $message."\n";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
return unless $self->canShowDebug || $self->getLogger->is_error;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->error($message);
|
||||
$self->getLogger->debug("Stack trace for ERROR ".$message."\n".$self->getStackTrace());
|
||||
$self->{_debug_error} .= $message."\n";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 fatal ( message [, flags] )
|
||||
|
||||
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.
|
||||
|
||||
=head3 message
|
||||
|
||||
The message to use.
|
||||
|
||||
=cut
|
||||
|
||||
sub fatal {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->session->http->setStatus("500","Server Error");
|
||||
#Apache2::RequestUtil->request->content_type('text/html') if ($self->session->request);
|
||||
$self->session->request->content_type('text/html') if ($self->session->request);
|
||||
$self->getLogger->fatal($message);
|
||||
$self->getLogger->debug("Stack trace for FATAL ".$message."\n".$self->getStackTrace());
|
||||
$self->session->http->sendHeader if ($self->session->request);
|
||||
|
||||
if (! defined $self->session->db(1)) {
|
||||
# We can't even _determine_ whether we can show the debug text. Punt.
|
||||
$self->session->output->print("<h1>Fatal Internal Error</h1>");
|
||||
$self->session->output->print("<p>".$message."</p>");
|
||||
}
|
||||
elsif ($self->canShowDebug()) {
|
||||
$self->session->output->print("<h1>WebGUI Fatal Error</h1><p>Something unexpected happened that caused this system to fault.</p>\n",1);
|
||||
$self->session->output->print("<p>".$message."</p>\n",1);
|
||||
$self->session->output->print("<pre>" . encode_entities($self->getStackTrace) . "</pre>", 1);
|
||||
$self->session->output->print($self->showDebug(),1);
|
||||
}
|
||||
else {
|
||||
# NOTE: You can't internationalize this because with some types of errors that would cause an infinite loop.
|
||||
$self->session->output->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.<br />",1);
|
||||
$self->session->output->print('<br />'.$self->session->setting->get("companyName"),1);
|
||||
$self->session->output->print('<br />'.$self->session->setting->get("companyEmail"),1);
|
||||
$self->session->output->print('<br />'.$self->session->setting->get("companyURL"),1);
|
||||
}
|
||||
$self->session->close();
|
||||
last WEBGUI_FATAL;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLogger ( )
|
||||
|
||||
Returns a reference to the logger.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLogger {
|
||||
my $self = shift;
|
||||
return $self->{_logger};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
return unless $self->canShowDebug || $self->getLogger->is_info;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->info($message);
|
||||
$self->{_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;
|
||||
Log::Log4perl->init_once( $session->config->getWebguiRoot."/etc/log.conf" );
|
||||
my $logger = Log::Log4perl->get_logger($session->config->getFilename);
|
||||
my $self = bless {_queryCount=>0, _logger=>$logger, _session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 preventDebugOutput ( )
|
||||
|
||||
Prevent this session from sending debugging output even if we're supposed to.
|
||||
|
||||
Some times we need to use 'text/html' to send non-html content (these may be
|
||||
browser limitations, but we need to work with them).
|
||||
|
||||
=cut
|
||||
|
||||
sub preventDebugOutput {
|
||||
my ( $self ) = @_;
|
||||
$self->{_preventDebugOutput} = 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 query ( sql )
|
||||
|
||||
Logs a sql statement for the debugger output. Keeps track of the #.
|
||||
|
||||
=head3 sql
|
||||
|
||||
A sql statement string.
|
||||
|
||||
=cut
|
||||
|
||||
sub query {
|
||||
my $self = shift;
|
||||
return unless $self->canShowDebug || $self->getLogger->is_debug;
|
||||
my $query = shift;
|
||||
my $placeholders = shift;
|
||||
$self->{_queryCount}++;
|
||||
my $plac;
|
||||
if (defined $placeholders and ref $placeholders eq "ARRAY" && scalar(@$placeholders)) {
|
||||
my @placeholders = map {ref $_ ? "$_" : $_} @$placeholders; # stringify objects
|
||||
$plac = "\n with placeholders: " . JSON->new->encode(\@placeholders);
|
||||
}
|
||||
else {
|
||||
$plac = '';
|
||||
}
|
||||
my $depth = 0;
|
||||
while (my ($caller) = caller(++$depth)) {
|
||||
last
|
||||
unless $caller eq __PACKAGE__ || $caller =~ /^WebGUI::SQL:?/;
|
||||
}
|
||||
|
||||
$query =~ s/^/ /gms;
|
||||
$self->{_debug_debug} .= sprintf "query %d - %s(%s) :\n%s%s\n",
|
||||
$self->{_queryCount}, (caller($depth + 1))[3,2], $query, $plac;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $depth + 1;
|
||||
$self->getLogger->debug("query $self->{_queryCount}:\n$query$plac");
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
$self->warn($self->session->user->username." (".$self->session->user->userId.") connecting from "
|
||||
.$self->session->env->getIp." attempted to ".$message);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 showDebug ( )
|
||||
|
||||
Creates an HTML formatted string of all internally stored debug information, warns,
|
||||
errors, sql queries and form data.
|
||||
|
||||
=cut
|
||||
|
||||
sub showDebug {
|
||||
my $self = shift;
|
||||
my $output = '<div class="webgui-debug" style="text-align: left;color: #000000; white-space: pre; float: left">';
|
||||
my $text = $self->{_debug_error};
|
||||
$text = encode_entities($text);
|
||||
$output .= '<div style="background-color: #800000;color: #ffffff">'.$text."</div>";
|
||||
$text = $self->{_debug_warn};
|
||||
$text = encode_entities($text);
|
||||
$output .= '<div style="background-color: #ffbdbd">'.$text."</div>";
|
||||
$text = $self->{_debug_info};
|
||||
$text = encode_entities($text);
|
||||
$output .= '<div style="background-color: #bdffbd">'.$text."</div>";
|
||||
my %form = %{ $self->session->form->paramsHashRef };
|
||||
$form{password} = "*******"
|
||||
if exists $form{password};
|
||||
$form{identifier} = "*******"
|
||||
if exists $form{identifier};
|
||||
$text = JSON->new->pretty->encode(\%form);
|
||||
$text = encode_entities($text);
|
||||
$output .= '<div style="background-color: #aaaaee">'.$text."</div>";
|
||||
$text = $self->{_debug_debug};
|
||||
$text = encode_entities($text);
|
||||
$output .= '<div style="background-color: #cccc55">'.$text."</div>";
|
||||
$output .= '</div>';
|
||||
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;
|
||||
return unless $self->canShowDebug || $self->getLogger->is_warn;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->warn($message);
|
||||
$self->{_debug_warn} .= $message."\n";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
195
lib/WebGUI/Session/Form.pm
Normal file
195
lib/WebGUI/Session/Form.pm
Normal file
|
|
@ -0,0 +1,195 @@
|
|||
package WebGUI::Session::Form;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::HTML;
|
||||
use Encode ();
|
||||
use base 'WebGUI::FormValidator';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Form
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a subclass of WebGUI::FormValidator. It processes POST input.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Session::Form;
|
||||
|
||||
my $fp = WebGUI::Session::Form->new($session);
|
||||
|
||||
$value = $fp->process("favoriteColor", "selectList", "black");
|
||||
|
||||
$value = $fp->someFormControlType("fieldName");
|
||||
|
||||
Example:
|
||||
|
||||
$value = $fp->text("title");
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 AUTOLOAD ( params )
|
||||
|
||||
This just passes control to WebGUI::FormValidator::AUTOLOAD.
|
||||
|
||||
=head3 params
|
||||
|
||||
Either an href of parameters or the fieldName in question.
|
||||
|
||||
=cut
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
our $AUTOLOAD;
|
||||
my $method = "SUPER::".(split /::/, $AUTOLOAD)[-1];
|
||||
return $self->$method(@args);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 hasParam ( $param )
|
||||
|
||||
Returns true if the param is part of the submitted form data, or a URL param.
|
||||
|
||||
=cut
|
||||
|
||||
sub hasParam {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
return undef unless $param;
|
||||
return undef unless $self->session->request;
|
||||
my $hashRef = $self->session->request->param();
|
||||
return exists $hashRef->{$param};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 paramsHashRef ( )
|
||||
|
||||
Gets a hash ref of all the params passed in to this class, and their values. This should not be confused with the param() method.
|
||||
|
||||
=cut
|
||||
|
||||
sub paramsHashRef {
|
||||
my $self = shift;
|
||||
unless ($self->{_paramsHashRef}) {
|
||||
my %hash;
|
||||
tie %hash, "Tie::IxHash";
|
||||
foreach ($self->param) {
|
||||
my @arr = $self->process($_);
|
||||
$hash{$_} = (scalar(@arr) > 1)?\@arr:$arr[0];
|
||||
}
|
||||
$self->{_paramsHashRef} = \%hash;
|
||||
}
|
||||
return $self->{_paramsHashRef};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 param ( [ field ] )
|
||||
|
||||
Returns all the fields from a form post as an array.
|
||||
|
||||
=head3 field
|
||||
|
||||
The name of the field to retrieve if you want to retrieve just one specific field.
|
||||
|
||||
=cut
|
||||
|
||||
sub param {
|
||||
my $self = shift;
|
||||
return undef unless $self->session->request;
|
||||
my $field = shift;
|
||||
if ($field) {
|
||||
my @data = $self->session->request->param($field);
|
||||
foreach my $value (@data) {
|
||||
$value = Encode::decode_utf8($value);
|
||||
}
|
||||
return wantarray ? @data : $data[0];
|
||||
}
|
||||
else {
|
||||
my $paramRef = $self->session->request->param;
|
||||
return keys %{ $paramRef };
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 process ( name, type [ , default, params ] )
|
||||
|
||||
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.
|
||||
|
||||
=head3 params
|
||||
|
||||
A full set of form params just as you'd pass into any of the form controls when building it.
|
||||
|
||||
=cut
|
||||
|
||||
sub process {
|
||||
my ($self, $name, $type, $default, $params) = @_;
|
||||
|
||||
return $self->param($name) if ($type eq "");
|
||||
$type = ucfirst($type);
|
||||
|
||||
return $self->SUPER::process({
|
||||
name => $name,
|
||||
type => $type,
|
||||
default => $default,
|
||||
params => $params,
|
||||
});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 validToken ( )
|
||||
|
||||
Checks that the current form has a method=POST, and that it has a CSRF token matching
|
||||
the one in this user's current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub validToken {
|
||||
my ($self) = @_;
|
||||
my $session = $self->session;
|
||||
return 0 unless $session->request->method eq 'POST';
|
||||
return 0 unless $self->param('webguiCsrfToken') eq $session->scratch->get('webguiCsrfToken');
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
604
lib/WebGUI/Session/Http.pm
Normal file
604
lib/WebGUI/Session/Http.pm
Normal file
|
|
@ -0,0 +1,604 @@
|
|||
package WebGUI::Session::Http;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::Utility;
|
||||
use Scalar::Util qw( weaken blessed );
|
||||
|
||||
=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} || 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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 = eval { APR::Request::Apache2->handle($self->session->request)->jar(); };
|
||||
return $jarHashRef if $jarHashRef;
|
||||
if (blessed $@ and $@->isa('APR::Request::Error')) {
|
||||
return $@->jar;
|
||||
}
|
||||
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.
|
||||
|
||||
=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 ifModifiedSince ( epoch [, maxCacheTimeout] )
|
||||
|
||||
Returns 1 if the epoch is greater than the modified date check.
|
||||
|
||||
=head3 epoch
|
||||
|
||||
The date that the requested content was last modified in epoch format.
|
||||
|
||||
=head3 maxCacheTimeout
|
||||
|
||||
A modifier to the epoch, that allows us to set a maximum timeout where content will appear to
|
||||
have changed and a new page request will be allowed to be processed.
|
||||
|
||||
=cut
|
||||
|
||||
sub ifModifiedSince {
|
||||
my $self = shift;
|
||||
my $epoch = shift;
|
||||
my $maxCacheTimeout = shift;
|
||||
require APR::Date;
|
||||
my $modified = $self->session->request->headers_in->{'If-Modified-Since'};
|
||||
return 1 if ($modified eq "");
|
||||
$modified = APR::Date::parse_http($modified);
|
||||
##Implement a step function that increments the epoch time in integer multiples of
|
||||
##the maximum cache time. Used to handle the case where layouts containing macros
|
||||
##(like assetproxied Navigations) can be periodically updated.
|
||||
if ($maxCacheTimeout) {
|
||||
my $delta = time() - $epoch;
|
||||
$epoch += $delta - ($delta % $maxCacheTimeout);
|
||||
}
|
||||
return ($epoch > $modified);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 isRedirect ( )
|
||||
|
||||
Returns a boolean value indicating whether the current page will redirect to some other location.
|
||||
|
||||
=cut
|
||||
|
||||
sub isRedirect {
|
||||
my $self = shift;
|
||||
return isIn($self->getStatus(), qw(302 301));
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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 unless defined $self->session->db(1);
|
||||
|
||||
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($self->getStatus);
|
||||
} else {
|
||||
$request->content_type($self->getMimeType);
|
||||
my $cacheControl = $self->getCacheControl;
|
||||
my $date = ($userId eq "1") ? $datetime->epochToHttp($self->getLastModified) : $datetime->epochToHttp;
|
||||
# under these circumstances, don't allow caching
|
||||
if ($userId ne "1" || $cacheControl eq "none" || $self->session->setting->get("preventProxyCache")) {
|
||||
$request->headers_out->set("Cache-Control" => "private, max-age=1");
|
||||
$request->no_cache(1);
|
||||
}
|
||||
# in all other cases, set cache, but tell it to ask us every time so we don't mess with recently logged in users
|
||||
else {
|
||||
if ( $cacheControl eq "none" ) {
|
||||
$request->headers_out->set("Cache-Control" => "private, max-age=1");
|
||||
$request->no_cache(1);
|
||||
}
|
||||
else {
|
||||
$request->headers_out->set('Last-Modified' => $date);
|
||||
$request->headers_out->set('Cache-Control' => "must-revalidate, max-age=" . $cacheControl);
|
||||
}
|
||||
# do an extra incantation if the HTTP protocol is really old
|
||||
if ($request->protocol =~ /(\d\.\d)/ && $1 < 1.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 undef;
|
||||
}
|
||||
|
||||
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 undef;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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; charset=UTF-8". 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, [ type ] )
|
||||
|
||||
Sets the necessary information in the HTTP header to redirect to another URL.
|
||||
|
||||
=head3 url
|
||||
|
||||
The URL to redirect to. To prevent infinite loops, no redirect will be set if
|
||||
url is the same as the current page, as found through $session->url->page.
|
||||
|
||||
=head3 type
|
||||
|
||||
Defaults to 302 (temporary redirect), but you can optionally set 301 (permanent redirect).
|
||||
|
||||
=cut
|
||||
|
||||
sub setRedirect {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my $type = shift || 302;
|
||||
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->setRedirectLocation($url);
|
||||
$self->setStatus($type, "Redirect");
|
||||
$self->session->style->setMeta({"http-equiv"=>"refresh",content=>"0; URL=".$url});
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setRedirectLocation ( url )
|
||||
|
||||
Sets the HTTP redirect URL.
|
||||
|
||||
=cut
|
||||
|
||||
sub setRedirectLocation {
|
||||
my $self = shift;
|
||||
$self->{_http}{location} = shift;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
|
||||
614
lib/WebGUI/Session/Icon.pm
Normal file
614
lib/WebGUI/Session/Icon.pm
Normal file
|
|
@ -0,0 +1,614 @@
|
|||
package WebGUI::Session::Icon;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::International;
|
||||
use Scalar::Util qw( weaken );
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Icon
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A package for generating user interface buttons. The subroutines found herein do nothing other than to create a short way of doing much longer repetitive tasks. They simply make the programmer's life easier through fewer keystrokes and less cluttered code.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Session::Icon;
|
||||
$html = $self->session->icon->copy('op=something');
|
||||
$html = $self->session->icon->cut('op=something');
|
||||
$html = $self->session->icon->delete('op=something');
|
||||
$html = $self->session->icon->drag();
|
||||
$html = $self->session->icon->edit('op=something');
|
||||
$html = $self->session->icon->manage('op=something');
|
||||
$html = $self->session->icon->moveBottom('op=something');
|
||||
$html = $self->session->icon->moveDown('op=something');
|
||||
$html = $self->session->icon->moveLeft('op=something');
|
||||
$html = $self->session->icon->moveRight('op=something');
|
||||
$html = $self->session->icon->moveTop('op=something');
|
||||
$html = $self->session->icon->moveUp('op=something');
|
||||
$html = $self->session->icon->shortcut('op=something');
|
||||
$html = $self->session->icon->view('op=something');
|
||||
|
||||
$hashRef = $self->session->icon->getToolbarOptions();
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getBaseURL ( )
|
||||
|
||||
Returns the base URL for this user's toolbar icon set.
|
||||
|
||||
=cut
|
||||
|
||||
sub getBaseURL {
|
||||
my $self = shift;
|
||||
my $url = $self->session->url->extras('toolbar/');
|
||||
my $toolbar = $self->session->user->profileField("toolbar");
|
||||
if ($toolbar ne "useLanguageDefault") {
|
||||
$url .= $toolbar;
|
||||
} else {
|
||||
$url .= WebGUI::International->new($self->session,'Icon')->getLanguage($self->session->user->profileField("language"),"toolbar");
|
||||
}
|
||||
$url .= '/';
|
||||
return $url;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 copy ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with the word "Copy" printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
=cut
|
||||
|
||||
sub copy {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'copy.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Copy').'" title="'.$i18n->get('Copy').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 cut ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with the word "Cut" printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
=cut
|
||||
|
||||
sub cut {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'cut.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Cut').'" title="'.$i18n->get('Cut').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete ( urlParameters [, pageURL, confirmText ] )
|
||||
|
||||
Generates a button that represents a delete operation.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=head3 confirmText
|
||||
|
||||
If defined, a confirm box will popup to ask the user if they want to delete.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $confirmText = shift;
|
||||
if($confirmText) {
|
||||
$confirmText = qq| onclick="return confirm('$confirmText');" |;
|
||||
}
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'" '.$confirmText.'>';
|
||||
$output .= '<img src="'.$self->getBaseURL().'delete.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Delete').'" title="'.$i18n->get('Delete').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drag ( extras )
|
||||
|
||||
Generates an icon that can be used to drag content.
|
||||
|
||||
=head2 extras
|
||||
|
||||
Classes, Ids, Javascript triggers, or whatever else you need to add to the image to make it a drag trigger.
|
||||
|
||||
=cut
|
||||
|
||||
sub drag {
|
||||
my $self = shift;
|
||||
my $extras = shift;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
return '<span class="toolbarIcon" style="vertical-align:middle;"><img '.$extras.' src="'.$self->getBaseURL().'drag.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Drag').'" title="'.$i18n->get('Drag').'" /></span>';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 edit ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with the word "Edit" printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
=cut
|
||||
|
||||
sub edit {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'edit.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Edit').'" title="'.$i18n->get('Edit').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 export ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates an export button.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub export {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'export.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Export').'" title="'.$i18n->get('Export').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getToolbarOptions ( )
|
||||
|
||||
Returns a hash reference containing the list of toolbar icon sets to be selected in user profile.
|
||||
|
||||
=cut
|
||||
|
||||
sub getToolbarOptions {
|
||||
my %options;
|
||||
tie %options, 'Tie::IxHash';
|
||||
my $self = shift;
|
||||
$options{useLanguageDefault} = WebGUI::International->new($self->session,'WebGUI')->get(1084);
|
||||
my $dir = $self->session->config->get("extrasPath")."/toolbar";
|
||||
opendir (DIR,$dir) or $self->session->errorHandler->warn("Can't open toolbar directory!: $!");
|
||||
my @files = readdir(DIR);
|
||||
foreach my $file (@files) {
|
||||
if (substr($file,0,1) ne ".") {
|
||||
$options{$file} = $file;
|
||||
}
|
||||
}
|
||||
closedir(DIR);
|
||||
return \%options;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 locked ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button that represents a management function. Is toggled out in place of the edit icon when an asset is locked.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub locked {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'locked.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('locked').'" title="'.$i18n->get('locked').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 manage ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button that represents a management function.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub manage {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'manage.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Manage').'" title="'.$i18n->get('Manage').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveBottom ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a double down arrow printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub moveBottom {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'moveBottom.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Move To Bottom').'" title="'.$i18n->get('Move To Bottom').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveDown ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a down arrow printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=head3 disabled
|
||||
|
||||
If this flag is true, the icon will be generated but no action link will be wrapped around it.
|
||||
|
||||
=cut
|
||||
|
||||
sub moveDown {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $disabled = shift;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;">';
|
||||
$output .= '<a href="'.$self->session->url->gateway($pageURL,$urlParams).'">' unless $disabled;
|
||||
$output .= '<img src="'.$self->getBaseURL().'moveDown.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Move Down').'" title="'.$i18n->get('Move Down').'" />';
|
||||
$output .= '</a>' unless $disabled;
|
||||
$output .= '</span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveLeft ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a left arrow printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub moveLeft {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'moveLeft.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Move Left').'" title="'.$i18n->get('Move Left').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveRight ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a right arrow printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub moveRight {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'moveRight.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Move Right').'" title="'.$i18n->get('Move Right').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveTop ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a double up arrow printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub moveTop {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'moveTop.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Move To Top').'" title="'.$i18n->get('Move To Top').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveUp ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with an up arrow printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=head3 disabled
|
||||
|
||||
If this flag is true, the icon will be generated but no action link will be wrapped around it.
|
||||
|
||||
=cut
|
||||
|
||||
sub moveUp {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $disabled = shift;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;">';
|
||||
$output .= '<a href="'.$self->session->url->gateway($pageURL,$urlParams).'">' unless $disabled;
|
||||
$output .= '<img src="'.$self->getBaseURL().'moveUp.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Move Up').'" title="'.$i18n->get('Move Up').'" />';
|
||||
$output .= '</a>' unless $disabled;
|
||||
$output .= '</span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 shortcut ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a shortcut symbol printed on it, similar to the shortcut icon in Microsoft Windows or the link Icon in Gnome.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub shortcut {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'shortcut.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('Create Shortcut').'" title="'.$i18n->get('Create Shortcut').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 view ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with the word "View" printed on it.
|
||||
|
||||
=head3 urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
|
||||
file will be prepended to it.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub view {
|
||||
my $self = shift;
|
||||
my $urlParams = shift;
|
||||
my $pageURL = shift || $self->session->url->getRequestedUrl;
|
||||
my $i18n = WebGUI::International->new($self->session,'Icon');
|
||||
my $output = '<span class="toolbarIcon" style="vertical-align:middle;"><a href="'.$self->session->url->gateway($pageURL,$urlParams).'">';
|
||||
$output .= '<img src="'.$self->getBaseURL().'view.gif" style="vertical-align:middle;border: 0px;" alt="'.$i18n->get('View').'" title="'.$i18n->get('View').'" /></a></span>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
184
lib/WebGUI/Session/Id.pm
Normal file
184
lib/WebGUI/Session/Id.pm
Normal file
|
|
@ -0,0 +1,184 @@
|
|||
package WebGUI::Session::Id;
|
||||
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Digest::MD5;
|
||||
use Scalar::Util qw( weaken );
|
||||
use Time::HiRes qw( gettimeofday usleep );
|
||||
use MIME::Base64;
|
||||
|
||||
my $idValidator = qr/^[A-Za-z0-9_-]{22}$/;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Id;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package generates global unique ids, sometimes called GUIDs. A global unique ID is guaranteed to be unique everywhere and at everytime.
|
||||
|
||||
B<NOTE:> There is no such thing as perfectly unique ID's, but the chances of a duplicate ID are so minute that they are effectively unique.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $id = $session->id->generate;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 fromHex ( hexId )
|
||||
|
||||
Returns the guid corresponding to hexId. Converse of toHex.
|
||||
|
||||
=head3 hexId
|
||||
|
||||
Hex value to convert to guid.
|
||||
|
||||
=cut
|
||||
|
||||
sub fromHex {
|
||||
my $self = shift;
|
||||
my $hexId = shift;
|
||||
my $binId = pack( 'H2' x 16, unpack( 'A2' x 16, $hexId ) );
|
||||
my $id = substr( encode_base64($binId), 0, 22 );
|
||||
$id =~ tr{+/}{_-};
|
||||
return $id;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getValidator
|
||||
|
||||
Get the regular expression used to validate generated GUIDs. This is just to prevent
|
||||
regular expressions from being duplicated all over the place.
|
||||
|
||||
=cut
|
||||
|
||||
sub getValidator {
|
||||
return $idValidator;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 generate
|
||||
|
||||
This function generates a global unique id.
|
||||
|
||||
=cut
|
||||
|
||||
sub generate {
|
||||
my $self = shift;
|
||||
my($s,$us)=gettimeofday();
|
||||
my($v)=sprintf("%09d%06d%10d%06d%255s",rand(999999999),$us,$s,$$,$self->session->config->getFilename);
|
||||
my $id = Digest::MD5::md5_base64($v);
|
||||
$id =~ tr{+/}{_-};
|
||||
return $id;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 toHex ( guid )
|
||||
|
||||
Returns the hex value of a guid. For all GUIDs generated by the generate method, the return value will be 32 characters long. For some manually created invalid GUIDs, it may be 33 characters long.
|
||||
|
||||
=head3 guid
|
||||
|
||||
guid to convert to hex value.
|
||||
|
||||
=cut
|
||||
|
||||
sub toHex {
|
||||
my $self = shift;
|
||||
my $id = shift;
|
||||
$id =~ tr{_-}{+/};
|
||||
$id .= 'AA';
|
||||
my $bin_id = decode_base64($id);
|
||||
my $hex_id = unpack("H*", $bin_id);
|
||||
$hex_id =~ s/0{3,4}$//;
|
||||
return $hex_id
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 valid ( $idString )
|
||||
|
||||
Returns true if $idString is a valid WebGUI guid.
|
||||
|
||||
=cut
|
||||
|
||||
sub valid {
|
||||
my ($self, $idString) = @_;
|
||||
return $idString =~ m/$idValidator/;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
104
lib/WebGUI/Session/Os.pm
Normal file
104
lib/WebGUI/Session/Os.pm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
package WebGUI::Session::Os;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::Os
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package allows you to reference environment variables.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$os = WebGUI::Session::Os->new;
|
||||
|
||||
$value = $os->get('name');
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( varName )
|
||||
|
||||
Retrieves the current value of an operating system variable.
|
||||
|
||||
=head3 varName
|
||||
|
||||
The name of the variable.
|
||||
|
||||
=head4 name
|
||||
|
||||
The name of the operating system as reported by perl.
|
||||
|
||||
=head4 type
|
||||
|
||||
Will either be "Windowsish" or "Linuxish", which is often more useful than name because the differences between various flavors of Unix, Linux, and BSD are usually not that significant.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
return $self->{_os}{$var};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( )
|
||||
|
||||
Constructor. Returns an OS object.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
$self->{_os}{name} = $^O;
|
||||
if ($self->{_os}{name} =~ /MSWin32/i || $self->{_os}{name} =~ /^Win/i) {
|
||||
$self->{_os}{type} = "Windowsish";
|
||||
} else {
|
||||
$self->{_os}{type} = "Linuxish";
|
||||
}
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
140
lib/WebGUI/Session/Output.pm
Normal file
140
lib/WebGUI/Session/Output.pm
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
package WebGUI::Session::Output;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::Macro;
|
||||
use Scalar::Util qw( weaken );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Output
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class provides a handler for returning output. Through this we can apply filters (like macros), and simple page caching mechanisms.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$session->output->print($content);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 print ( content, skipMacros )
|
||||
|
||||
Outputs content to either the web server or standard out, depending on which is available.
|
||||
|
||||
=head3 content
|
||||
|
||||
The content to output.
|
||||
|
||||
=head3 skipMacros
|
||||
|
||||
A boolean indicating whether to skip macro processing on this content. If the mime type
|
||||
has been set to a non-text type, macros will automatically be skipped.
|
||||
|
||||
=cut
|
||||
|
||||
sub print {
|
||||
my $self = shift;
|
||||
my $content = shift;
|
||||
my $skipMacros = shift || !($self->session->http->getMimeType =~ /^text/);
|
||||
WebGUI::Macro::process($self->session, \$content) unless $skipMacros;
|
||||
my $handle = $self->{_handle};
|
||||
if (defined $handle) {
|
||||
print $handle $content;
|
||||
}
|
||||
elsif ($self->session->request) {
|
||||
$self->session->request->print($content);
|
||||
}
|
||||
else {
|
||||
print $content;
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setHandle ( handle )
|
||||
|
||||
Sets a handle to print the content to. If we're running in command line mode, WebGUI assumes we're printing to standard out, and if we were called through mod_perl it assumes we're printing to that.
|
||||
|
||||
=head3 handle
|
||||
|
||||
An open FILE handle that WebGUI can print to.
|
||||
|
||||
=cut
|
||||
|
||||
sub setHandle {
|
||||
my $self = shift;
|
||||
my $handle = shift;
|
||||
$self->{_handle} = $handle;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
231
lib/WebGUI/Session/Privilege.pm
Normal file
231
lib/WebGUI/Session/Privilege.pm
Normal file
|
|
@ -0,0 +1,231 @@
|
|||
package WebGUI::Session::Privilege;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Scalar::Util qw( weaken );
|
||||
use WebGUI::International;
|
||||
use WebGUI::Operation::Auth;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Privilege
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package provides access to the WebGUI security system and security messages.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
|
||||
|
||||
use WebGUI::Session::Privilege;
|
||||
|
||||
$privilege = $session->privilege;
|
||||
$privilege = WebGUI::Session::Privilege->new($session);
|
||||
|
||||
$html = $privilege->adminOnly();
|
||||
$html = $privilege->insufficient();
|
||||
$html = $privilege->noAccess();
|
||||
$html = $privilege->notMember();
|
||||
$html = $privilege->vitalComponent();
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 adminOnly ( )
|
||||
|
||||
Returns a message stating that this functionality can only be used by administrators. This method also sets the HTTP header status to 401.
|
||||
|
||||
=cut
|
||||
|
||||
sub adminOnly {
|
||||
my $self = shift;
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
$self->session->http->setStatus("401", "Admin Only");
|
||||
my $output = '<h1>'.$i18n->get(35).'</h1>';
|
||||
$output .= $i18n->get(36);
|
||||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 insufficient ( )
|
||||
|
||||
Returns a message stating that the user does not have the required privileges to perform the operation they requested. This method also sets the HTTP header status to 401.
|
||||
|
||||
=cut
|
||||
|
||||
sub insufficient {
|
||||
my $self = shift;
|
||||
my $noStyle = shift;
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
$self->session->http->setStatus("401", "Insufficient Privileges");
|
||||
my $output = '<h1>'.$i18n->get(37).'</h1>';
|
||||
if ($noStyle) {
|
||||
$self->session->style->useEmptyStyle(1);
|
||||
$output .= $i18n->get('bare insufficient');
|
||||
}
|
||||
else {
|
||||
$output .= $i18n->get(38);
|
||||
}
|
||||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 locked ( )
|
||||
|
||||
Returns a message stating that Asset is locked. This is a variation of insufficient with
|
||||
a different error message.
|
||||
|
||||
=cut
|
||||
|
||||
sub locked {
|
||||
my $self = shift;
|
||||
my $noStyle = shift;
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
$self->session->http->setStatus("401", "Insufficient Privileges");
|
||||
my $output = '<h1>'.$i18n->get(37).'</h1>';
|
||||
if ($noStyle) {
|
||||
$self->session->style->useEmptyStyle(1);
|
||||
$output .= $i18n->get('asset locked');
|
||||
}
|
||||
else {
|
||||
$output .= $i18n->get('asset locked');
|
||||
}
|
||||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 noAccess ( )
|
||||
|
||||
Returns a message stating that the user does not have the privileges necessary to access this page. This method also sets the HTTP header status to 401.
|
||||
|
||||
=cut
|
||||
|
||||
sub noAccess {
|
||||
my $self = shift;
|
||||
$self->session->http->setStatus("401", "No Access");
|
||||
if ($self->session->user->isVisitor) {
|
||||
return WebGUI::Operation::Auth::www_auth($self->session, "init");
|
||||
} else {
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
my $output = '<h1>'.$i18n->get(37).'</h1>';
|
||||
$output .= $i18n->get(39);
|
||||
$output .= '<p>';
|
||||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 notMember ( )
|
||||
|
||||
Returns a message stating that the user they requested information about is no longer active on this server. This method also sets the HTTP header status to 400.
|
||||
|
||||
=cut
|
||||
|
||||
sub notMember {
|
||||
my $self = shift;
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
$self->session->http->setStatus("400", "Not A Member");
|
||||
my ($output);
|
||||
$output = '<h1>'.$i18n->get(345).'</h1>';
|
||||
$output .= $i18n->get(346);
|
||||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 vitalComponent ( )
|
||||
|
||||
Returns a message stating that the user made a request to delete something that should never delete. This method also sets the HTTP header status to 403.
|
||||
|
||||
=cut
|
||||
|
||||
sub vitalComponent {
|
||||
my $self = shift;
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
$self->session->http->setStatus("403", "Vital Component");
|
||||
my ($output);
|
||||
$output = '<h1>'.$i18n->get(40).'</h1>';
|
||||
$output .= $i18n->get(41);
|
||||
$output .= '<p>';
|
||||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
277
lib/WebGUI/Session/Scratch.pm
Normal file
277
lib/WebGUI/Session/Scratch.pm
Normal file
|
|
@ -0,0 +1,277 @@
|
|||
package WebGUI::Session::Scratch;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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::International;
|
||||
use Scalar::Util qw( weaken );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Scratch
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package allows you to attach arbitrary data to the session that lasts until the session dies.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$scratch = WebGUI::Session::Scratch->new($session);
|
||||
|
||||
$scratch->delete('temp');
|
||||
$scratch->set('temp',$value);
|
||||
$value = $scratch->get('temp');
|
||||
|
||||
$scratch->deleteAll;
|
||||
$scratch->deleteName('temp');
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete ( name )
|
||||
|
||||
Deletes a scratch variable. Returns the value of the deleted variable for
|
||||
convenience, or undef if the variable was not defined.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the scratch variable.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
return undef unless ($name);
|
||||
my $value = delete $self->{_data}{$name};
|
||||
$self->session->db->write("delete from userSessionScratch where name=? and sessionId=?", [$name, $self->session->getId]);
|
||||
return $value;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 deleteAll ( )
|
||||
|
||||
Deletes all scratch variables for this session.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteAll {
|
||||
my $self = shift;
|
||||
delete $self->{_data};
|
||||
$self->session->db->write("delete from userSessionScratch where sessionId=?", [$self->session->getId]);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 deleteName ( name )
|
||||
|
||||
Deletes a scratch variable for all users. This function must be used with care.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the scratch variable.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteName {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
return undef unless ($name);
|
||||
delete $self->{_data}{$name};
|
||||
$self->session->db->write("delete from userSessionScratch where name=?", [$name]);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 deleteNameByValue ( name, value )
|
||||
|
||||
Deletes a scratch variable for all users where a particular name equals a particular value. This function must be used with care.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the scratch variable.
|
||||
|
||||
=head3 value
|
||||
|
||||
The value to match. This can be anything except for undef.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteNameByValue {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
return undef unless ($name and defined $value);
|
||||
delete $self->{_data}{$name} if ($self->{_data}{$name} eq $value);
|
||||
$self->session->db->write("delete from userSessionScratch where name=? and value=?", [$name,$value]);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( varName )
|
||||
|
||||
Retrieves the current value of a scratch variable.
|
||||
|
||||
=head3 varName
|
||||
|
||||
The name of the variable.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
return $self->{_data}{$var};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLanguageOverride ()
|
||||
|
||||
Retrieves the language of the session scratch
|
||||
|
||||
=cut
|
||||
|
||||
sub getLanguageOverride {
|
||||
my $self = shift;
|
||||
my $languageOverride = $self->session->scratch->get('language');
|
||||
return $languageOverride;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor. Returns a scratch object.
|
||||
|
||||
=head3 session
|
||||
|
||||
The current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $data = $session->db->buildHashRef("select name,value from userSessionScratch where sessionId=?",[$session->getId], {noOrder => 1});
|
||||
my $self = bless {_session=>$session, _data=>$data}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 removeLanguageOverride()
|
||||
|
||||
Removes the language scratch variable from the session
|
||||
|
||||
=cut
|
||||
|
||||
sub removeLanguageOverride {
|
||||
my $self = shift;
|
||||
$self->session->scratch->delete('language');
|
||||
}
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the WebGUI::Session object.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 set ( name, value )
|
||||
|
||||
Sets a scratch variable for this user session.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the scratch variable.
|
||||
|
||||
=head3 value
|
||||
|
||||
The value of the scratch variable. Must be a string no longer than 16000 characters.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
return undef unless ($name);
|
||||
$self->{_data}{$name} = $value;
|
||||
$self->session->db->write("insert into userSessionScratch (sessionId, name, value) values (?,?,?) on duplicate key update value=VALUES(value)", [$self->session->getId, $name, $value]);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
=head2 setLanguageOverride ( language )
|
||||
|
||||
Sets a scratch variable language in the session if the language is installed
|
||||
|
||||
=head3 language
|
||||
|
||||
The language that should be set into the session
|
||||
|
||||
=cut
|
||||
|
||||
sub setLanguageOverride {
|
||||
my $self = shift;
|
||||
my $language = shift;
|
||||
my $i18n = WebGUI::International->new($self->session);
|
||||
if($i18n->getLanguages()->{$language}) {
|
||||
$self->session->scratch->set("language",$language);
|
||||
return undef;
|
||||
}
|
||||
else {
|
||||
$self->session->log->error("Language $language is not installed in this site");
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
217
lib/WebGUI/Session/Setting.pm
Normal file
217
lib/WebGUI/Session/Setting.pm
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
package WebGUI::Session::Setting;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Scalar::Util qw( weaken );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::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::Session::Setting;
|
||||
|
||||
$settings = WebGUI::Session::Setting->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;
|
||||
$self->set(@_);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( $param )
|
||||
|
||||
Returns a hash reference containing all the settings.
|
||||
|
||||
=head3 $param
|
||||
|
||||
If $param is defined, then it will return only the setting for that param.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
if (defined $param) {
|
||||
return $self->{_settings}{$param};
|
||||
}
|
||||
else {
|
||||
return $self->{_settings};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 has ( $param )
|
||||
|
||||
Returns true if the requested setting exists in this object's cache of the settings.
|
||||
This works better than using ->get, since it doesn't care about the truthiness of
|
||||
the value of the setting.
|
||||
|
||||
This method will have little use outside of upgrade and install scripts, to prevent
|
||||
them from creating and/or overwriting existing settings.
|
||||
|
||||
=head3 $param
|
||||
|
||||
The setting to check.
|
||||
|
||||
=cut
|
||||
|
||||
sub has {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
return exists $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", [], {noOrder => 1});
|
||||
my $self = bless {_settings=>$settings, _session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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=?",[$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 $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
$self->{_settings}{$name} = $value;
|
||||
$self->session->db->write("REPLACE INTO settings (name, value) VALUES (?, ?)", [$name, $value]);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
205
lib/WebGUI/Session/Stow.pm
Normal file
205
lib/WebGUI/Session/Stow.pm
Normal file
|
|
@ -0,0 +1,205 @@
|
|||
package WebGUI::Session::Stow;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Scalar::Util qw( weaken );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Stow
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package allows you to "stow" a scalar or a reference to any other perl structure for the duration of the request. It's sort of like a mini in memory cache that only exists until $session->close is called. It is great to stow stuff that might otherwise have to be requested many times during a single page view, but that you would't want to store in the regular cache. Note that this is NOT supposed to be used as a global variable system. It's simply an in memory cache.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$stow = WebGUI::Session::Stow->new($session);
|
||||
|
||||
$stow->delete('temp');
|
||||
$stow->set('temp',$value);
|
||||
$value = $stow->get('temp');
|
||||
|
||||
$stow->deleteAll;
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete ( name )
|
||||
|
||||
Deletes a stow variable.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the stow variable.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
return undef unless ($name);
|
||||
delete $self->{_data}{$name};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 deleteAll ( )
|
||||
|
||||
Deletes all stow variables for this session.
|
||||
|
||||
=cut
|
||||
|
||||
sub deleteAll {
|
||||
my $self = shift;
|
||||
delete $self->{_data};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( varName )
|
||||
|
||||
Retrieves the current value of a stow variable. By default, will try
|
||||
to create a safe copy.
|
||||
|
||||
WARNING: Not all structures can be made completely safe. Objects will
|
||||
not be cloned.
|
||||
|
||||
=head3 varName
|
||||
|
||||
The name of the variable.
|
||||
|
||||
=head3 options
|
||||
|
||||
A hashref of options with the following keys:
|
||||
|
||||
noclone - If true, will not create a safe copy. This can be much much
|
||||
faster than creating a safe copy. Defaults to false.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
my $opt = shift || {};
|
||||
return undef if $self->session->config->get("disableCache");
|
||||
my $value = $self->{_data}{$var};
|
||||
return undef unless defined $value;
|
||||
my $ref = ref $value;
|
||||
return $value if ( !$ref || $opt->{noclone} );
|
||||
|
||||
# Try to clone
|
||||
# NOTE: Clone and Storable::dclone do not currently work here, but
|
||||
# would be safer if they did
|
||||
if ($ref eq 'ARRAY') {
|
||||
my @safeArray = @{ $value };
|
||||
return \@safeArray;
|
||||
}
|
||||
elsif ($ref eq 'HASH') {
|
||||
my %safeHash = %{ $value };
|
||||
return \%safeHash;
|
||||
}
|
||||
|
||||
# Can't figure out how to clone
|
||||
return $value;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor. Returns a stow object.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
$_[0]->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 set ( name, value )
|
||||
|
||||
Stows some data.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of the stow variable.
|
||||
|
||||
=head3 value
|
||||
|
||||
The value of the stow variable. Any scalar or reference.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
$self->session->errorHandler->debug('Stow->set() is being called but cache has been disabled')
|
||||
if $self->session->config->get("disableCache");
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
return undef unless ($name);
|
||||
$self->{_data}{$name} = $value;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
566
lib/WebGUI/Session/Style.pm
Normal file
566
lib/WebGUI/Session/Style.pm
Normal file
|
|
@ -0,0 +1,566 @@
|
|||
package WebGUI::Session::Style;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Scalar::Util qw( weaken );
|
||||
use WebGUI::International;
|
||||
use WebGUI::Macro;
|
||||
use WebGUI::Asset::Template;
|
||||
eval { require WebGUI; import WebGUI; };
|
||||
use HTML::Entities ();
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Style
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package contains utility methods for WebGUI's style system.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Session::Style;
|
||||
$style = WebGUI::Session::Style->new($session);
|
||||
|
||||
$html = $style->generateAdditionalHeadTags();
|
||||
$html = $style->process($content);
|
||||
|
||||
$session = $style->session;
|
||||
|
||||
$style->makePrintable(1);
|
||||
$style->setLink($url,\%params);
|
||||
$style->setMeta(\%params);
|
||||
$style->setRawHeadTags($html);
|
||||
$style->setScript($url, \%params);
|
||||
$style->useEmptyStyle(1);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _generateAdditionalTags {
|
||||
my $var = shift;
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $tags = $self->{$var};
|
||||
delete $self->{$var};
|
||||
WebGUI::Macro::process($self->session,\$tags);
|
||||
return $tags;
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 generateAdditionalBodyTags ( )
|
||||
|
||||
Creates tags that were set using setScript (if inBody was true) and setRawBodyTags.
|
||||
Macros are processed in the tags if processed by this method.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { *generateAdditionalBodyTags = _generateAdditionalTags('_rawBody') }
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 generateAdditionalHeadTags ( )
|
||||
|
||||
Creates tags that were set using setLink, setMeta, setScript, extraHeadTags, and setRawHeadTags.
|
||||
Macros are processed in the tags if processed by this method.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { *generateAdditionalHeadTags = _generateAdditionalTags('_raw') }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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 mobileBrowser ( )
|
||||
|
||||
Returns true if the user's browser matches any of the mobile browsers set in the config file.
|
||||
|
||||
=cut
|
||||
|
||||
sub mobileBrowser {
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
my $ua = $session->env->get('HTTP_USER_AGENT');
|
||||
for my $mobileUA (@{ $session->config->get('mobileUserAgents') }) {
|
||||
if ($ua =~ m/$mobileUA/) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 useMobileStyle
|
||||
|
||||
Returns a true value if we are on a mobile display.
|
||||
|
||||
=cut
|
||||
|
||||
sub useMobileStyle {
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
my $scratchCheck = $session->scratch->get('useMobileStyle');
|
||||
if (defined $scratchCheck) {
|
||||
return $scratchCheck;
|
||||
}
|
||||
if (exists $self->{_useMobileStyle}) {
|
||||
return $self->{_useMobileStyle};
|
||||
}
|
||||
|
||||
if (! $session->setting->get('useMobileStyle')) {
|
||||
return $self->{_useMobileStyle} = 0;
|
||||
}
|
||||
if ($self->mobileBrowser) {
|
||||
return $self->{_useMobileStyle} = 1;
|
||||
}
|
||||
return $self->{_useMobileStyle} = 0;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setMobileStyle
|
||||
|
||||
Sets whether the mobile style should be used for this session.
|
||||
|
||||
=cut
|
||||
|
||||
sub setMobileStyle {
|
||||
my $self = shift;
|
||||
my $enableMobile = shift;
|
||||
$self->session->scratch->set('useMobileStyle', $enableMobile);
|
||||
return $enableMobile;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 process ( content, templateId )
|
||||
|
||||
Returns a parsed style with content based upon the current WebGUI session information.
|
||||
Sets the C<sent> method/flag to be true so that subsequent head data is processed
|
||||
right away.
|
||||
|
||||
=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.
|
||||
If $style->useEmptyStyle has been set, then the empty style
|
||||
templateId will be used over templateId. If personalStyleId
|
||||
is set in $session->scratch, then that id will be used over the
|
||||
other two. Finally, if $style->makePrintable has been called,
|
||||
process will try to find a template for making the output printable
|
||||
from $style->printableStyleId, from $session->asset or from any of
|
||||
$session->asset's ancestors.
|
||||
|
||||
=cut
|
||||
|
||||
sub process {
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
my %var;
|
||||
$var{'body.content'} = shift;
|
||||
my $templateId = shift;
|
||||
if ($self->{_makePrintable} && $self->session->asset) {
|
||||
$templateId = $self->{_printableStyleId} || $session->asset->get("printableStyleTemplateId");
|
||||
my $currAsset = $session->asset;
|
||||
my $rootAssetId = WebGUI::Asset->getRoot($session)->getId;
|
||||
TEMPLATE: until ($templateId) {
|
||||
# some assets don't have this property. But at least one ancestor should....
|
||||
$currAsset = $currAsset->getParent;
|
||||
$templateId = $currAsset->get("printableStyleTemplateId");
|
||||
last TEMPLATE if $currAsset->getId eq $rootAssetId;
|
||||
}
|
||||
} elsif ($session->scratch->get("personalStyleId") ne "") {
|
||||
$templateId = $session->scratch->get("personalStyleId");
|
||||
} elsif ($self->{_useEmptyStyle}) {
|
||||
$templateId = 'PBtmpl0000000000000132';
|
||||
}
|
||||
$var{'head.tags'} = '
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
|
||||
<meta name="generator" content="WebGUI '.$WebGUI::VERSION.'" />
|
||||
<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"] = "' . $session->url->extras().'";
|
||||
props["pageURL"] = "' . $session->url->page(undef, undef, 1).'";
|
||||
props["firstDayOfWeek"] = "'. $session->user->get('firstDayOfWeek').'";
|
||||
return props[propName];
|
||||
}
|
||||
</script>
|
||||
' . $self->session->setting->get('globalHeadTags') . '
|
||||
<!--morehead-->
|
||||
';
|
||||
|
||||
if ($self->session->user->isRegistered || $self->session->setting->get("preventProxyCache")) {
|
||||
# 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, private" />
|
||||
<meta http-equiv="Expires" content="0" />
|
||||
';
|
||||
$self->session->http->setCacheControl("none");
|
||||
} else {
|
||||
$var{'head.tags'} .= '<meta http-equiv="Cache-Control" content="must-revalidate" />'
|
||||
}
|
||||
|
||||
# Removing the newlines will probably annoy people.
|
||||
# Perhaps turn it off under debug mode?
|
||||
$var{'head.tags'} =~ s/\n//g;
|
||||
|
||||
# head.tags = head_attachments . body_attachments
|
||||
# keeping head.tags for backwards compatibility
|
||||
$var{'head_attachments'} = $var{'head.tags'};
|
||||
$var{'head.tags'} .= ($var{'body_attachments'} = '<!--morebody-->');
|
||||
|
||||
my $style = WebGUI::Asset::Template->new($self->session,$templateId);
|
||||
my $output;
|
||||
if (defined $style) {
|
||||
my $meta = {};
|
||||
if ($self->session->setting->get("metaDataEnabled")) {
|
||||
$meta = $style->getMetaDataFields();
|
||||
}
|
||||
foreach my $field (keys %$meta) {
|
||||
$var{$meta->{$field}{fieldName}} = $meta->{$field}{value};
|
||||
}
|
||||
$output = $style->process(\%var);
|
||||
} else {
|
||||
$output = sprintf "WebGUI was unable to instantiate your style template with the id: %s.%s", $templateId, $var{'body.content'};
|
||||
}
|
||||
WebGUI::Macro::process($self->session,\$output);
|
||||
$self->sent(1);
|
||||
my $macroHeadTags = $self->generateAdditionalHeadTags();
|
||||
my $macroBodyTags = $self->generateAdditionalBodyTags();
|
||||
$output =~ s/\<\!--morehead--\>/$macroHeadTags/;
|
||||
$output =~ s/\<\!--morebody--\>/$macroBodyTags/;
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 sent ( boolean )
|
||||
|
||||
Returns a boolean indicating whether the style has already been sent. This is important when trying to set things to the HTML head block.
|
||||
|
||||
=head3 boolean
|
||||
|
||||
Set the value.
|
||||
|
||||
=cut
|
||||
|
||||
sub sent {
|
||||
my $self = shift;
|
||||
my $boolean = shift;
|
||||
if (defined $boolean) {
|
||||
$self->session->stow->set("styleHeadSent",$boolean);
|
||||
return $boolean;
|
||||
}
|
||||
return $self->session->stow->get("styleHeadSent");
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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. Tags are normally cached until the $style->sent
|
||||
flag is set to be true. If this method is called after that sent is
|
||||
true, then the tag will be sent immediately, but will not be processed
|
||||
for macros.
|
||||
|
||||
=head3 url
|
||||
|
||||
The URL to the document you are linking. Only one link can be set per url. If a link to this URL exists,
|
||||
the old link will remain and this method will return undef.
|
||||
|
||||
=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;
|
||||
$params = {} unless (defined $params and ref $params eq 'HASH');
|
||||
return undef if ($self->{_link}{$url});
|
||||
my $tag = '<link href="'.$url.'"';
|
||||
foreach my $name (keys %{$params}) {
|
||||
$tag .= ' '.$name.'="'.HTML::Entities::encode($params->{$name}).'"';
|
||||
}
|
||||
$tag .= ' />'."\n";
|
||||
$self->{_link}{$url} = 1;
|
||||
$self->setRawHeadTags($tag);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setPrintableStyleId ( params )
|
||||
|
||||
Overrides current printable style id defined in assets definition
|
||||
|
||||
=head3 params
|
||||
|
||||
scalar containing id of style to use
|
||||
|
||||
=cut
|
||||
|
||||
sub setPrintableStyleId {
|
||||
my $self = shift;
|
||||
my $styleId = shift;
|
||||
|
||||
$self->{_printableStyleId} = $styleId;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setMeta ( params )
|
||||
|
||||
Sets a <meta> tag into the <head> of this rendered page for this
|
||||
page view. Tags are normally cached until the $style->sent flag is
|
||||
set to be true. If this method is called after that sent is true,
|
||||
then the tag will be sent immediately, but will not be processed
|
||||
|
||||
=head3 params
|
||||
|
||||
A hash reference containing the parameters of the meta tag.
|
||||
|
||||
=cut
|
||||
|
||||
sub setMeta {
|
||||
my $self = shift;
|
||||
my $params = shift;
|
||||
my $tag = '<meta';
|
||||
foreach my $name (keys %{$params}) {
|
||||
$tag .= ' '.$name.'="'.$params->{$name}.'"';
|
||||
}
|
||||
$tag .= ' />'."\n";
|
||||
$self->setRawHeadTags($tag);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _setRawTags {
|
||||
my $var = shift;
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $tags = shift;
|
||||
if ($self->sent) {
|
||||
$self->session->output->print($tags);
|
||||
}
|
||||
else {
|
||||
$self->{$var} .= $tags;
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setRawBodyTags ( tags )
|
||||
|
||||
Does exactly the same thing as setRawHeadTags, except that the tags will be
|
||||
appended to a seperate variable (to be output after the body if the style
|
||||
template supports it) instead.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { *setRawBodyTags = _setRawTags('_rawBody') }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setRawHeadTags ( tags )
|
||||
|
||||
Sets data to be output into the <head> of the current rendered page
|
||||
for this page view. Tags are normally cached until the $style->sent
|
||||
flag is set to be true. If this method is called after that sent is
|
||||
true, then the tag will be sent immediately, but will not be processed
|
||||
for macros.
|
||||
|
||||
=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
|
||||
|
||||
BEGIN { *setRawHeadTags = _setRawTags('_raw') }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setScript ( url, params, [inBody] )
|
||||
|
||||
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. Tags are normally cached until the
|
||||
$style->sent flag is set to be true. If this method is called after
|
||||
that sent is true, then the tag will be sent immediately, but will
|
||||
not be processed for macros.
|
||||
|
||||
=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".
|
||||
|
||||
=head3 inBody
|
||||
|
||||
Optional, defaults to false. If true, the script will be added to the
|
||||
body_attachments variable instead of to head_attachments.
|
||||
|
||||
=cut
|
||||
|
||||
sub setScript {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my $params = shift;
|
||||
my $inBody = shift;
|
||||
return undef if ($self->{_javascript}{$url});
|
||||
my $tag = '<script src="'.$url.'"';
|
||||
foreach my $name (keys %{$params}) {
|
||||
$tag .= ' '.$name.'="'.HTML::Entities::encode($params->{$name}).'"';
|
||||
}
|
||||
$tag .= '></script>'."\n";
|
||||
$self->{_javascript}{$url} = 1;
|
||||
if ($inBody) {
|
||||
$self->setRawBodyTags($tag);
|
||||
}
|
||||
else {
|
||||
$self->setRawHeadTags($tag);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 userStyle ( content )
|
||||
|
||||
Wrapper's the content in the user style defined in the settings.
|
||||
|
||||
=head3 content
|
||||
|
||||
The content to be wrappered.
|
||||
|
||||
=cut
|
||||
|
||||
sub userStyle {
|
||||
my $self = shift;
|
||||
my $output = shift;
|
||||
$self->session->http->setCacheControl("none");
|
||||
if (defined $output) {
|
||||
return $self->process($output,$self->session->setting->get("userFunctionStyleId"));
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
562
lib/WebGUI/Session/Url.pm
Normal file
562
lib/WebGUI/Session/Url.pm
Normal file
|
|
@ -0,0 +1,562 @@
|
|||
package WebGUI::Session::Url;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 URI;
|
||||
use URI::Escape;
|
||||
use Scalar::Util qw( weaken );
|
||||
use WebGUI::International;
|
||||
use WebGUI::Utility;
|
||||
use Encode;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Url
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package provides URL writing functionality. It is important that all WebGUI URLs be written using these methods so that they can contain any extra information that WebGUI needs to add to the URLs in order to function properly.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Session::Url;
|
||||
|
||||
$url = WebGUI::Session::Url->new($session);
|
||||
|
||||
$string = $url->append($base, $pairs);
|
||||
$string = $url->escape($string);
|
||||
$string = $url->extras($path);
|
||||
$string = $url->gateway($pageUrl, $pairs);
|
||||
$string = $url->getRequestedUrl;
|
||||
$string = $url->getSiteURL;
|
||||
$string = $url->makeCompliant($string);
|
||||
$string = $url->makeAbsolute($string);
|
||||
$string = $url->page($pairs);
|
||||
$string = $url->unescape($string);
|
||||
$string = $url->urlize($string);
|
||||
|
||||
$url->setSiteURL($string);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 append ( url, pairs )
|
||||
|
||||
Returns a URL after adding form parameters to the end of it. This will always
|
||||
use the correct character for appending form parameters, so it can safely
|
||||
be called several times. If no parameters exist in the string, it will append
|
||||
with '?'. Otherwise, it uses a semicolon.
|
||||
|
||||
=head3 url
|
||||
|
||||
The URL to append information to.
|
||||
|
||||
=head3 pairs
|
||||
|
||||
Name value pairs, as a single string, to add to the end of the URL
|
||||
|
||||
name1=value1;name2=value2;name3=value3
|
||||
or name1=value1
|
||||
or name1=value1;name2=value2
|
||||
|
||||
=cut
|
||||
|
||||
sub append {
|
||||
my $self = shift;
|
||||
my ($url);
|
||||
$url = $_[0];
|
||||
if ($url =~ /\?/) {
|
||||
$url .= ';'.$_[1];
|
||||
} else {
|
||||
$url .= '?'.$_[1];
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 escape ( string )
|
||||
|
||||
Encodes a string to make it safe to pass in a URL.
|
||||
|
||||
B<NOTE:> See $self->session->url->unescape()
|
||||
|
||||
=head3 string
|
||||
|
||||
The string to escape.
|
||||
|
||||
=cut
|
||||
|
||||
sub escape {
|
||||
my $self = shift;
|
||||
return URI::Escape::uri_escape_utf8(shift);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 extras ( path )
|
||||
|
||||
Combines the base extrasURL defined in the config file with a specified path.
|
||||
|
||||
=head3 path
|
||||
|
||||
The path to the thing in the extras folder that you're
|
||||
referencing. Note that the leading / is not necessary. Multiple
|
||||
consecutive slashes in the path part of the URL will be replaced with a single slash.
|
||||
|
||||
=cut
|
||||
|
||||
sub extras {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
my $url = $self->session->config->get("extrasURL");
|
||||
my $cdnCfg = $self->session->config->get('cdn');
|
||||
if ( $cdnCfg and $cdnCfg->{'enabled'} and $cdnCfg->{'extrasCdn'} ) {
|
||||
unless ( $path and grep $path =~ m/$_/, @{ $cdnCfg->{'extrasExclude'} } ) {
|
||||
if ($cdnCfg->{'extrasSsl'} && $self->session->env->sslRequest) {
|
||||
$url = $cdnCfg->{'extrasSsl'};
|
||||
}
|
||||
else {
|
||||
$url = $cdnCfg->{'extrasCdn'};
|
||||
}
|
||||
} # if excluded, stick with regular extrasURL
|
||||
}
|
||||
$url .= '/' . $path;
|
||||
$url =~ s$(?<!:)/{2,}$/$g; ##Remove //, unless it's after a :, which can't be a valid URL character
|
||||
return $url;
|
||||
} ## end sub extras
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 gateway ( pageURL [ , pairs ] )
|
||||
|
||||
Generate a URL based on WebGUI's location directive.
|
||||
|
||||
=head3 pageURL
|
||||
|
||||
The url of an asset that you wish to create a fully qualified URL for.
|
||||
|
||||
=head3 pairs
|
||||
|
||||
Name value pairs to add to the URL in the form of:
|
||||
|
||||
name1=value1;name2=value2;name3=value3
|
||||
|
||||
=head3 skipPreventProxyCache
|
||||
|
||||
If preventing proxy caching is enabled in the settings, then if
|
||||
skipPreventProxyCache is a 1 will override that and prevent the
|
||||
noCache param from being added to the URL.
|
||||
|
||||
=cut
|
||||
|
||||
sub gateway {
|
||||
my $self = shift;
|
||||
my $pageUrl = shift;
|
||||
my $pairs = shift;
|
||||
my $skipPreventProxyCache = shift;
|
||||
my $url = $self->session->config->get("gateway").'/'.$pageUrl;
|
||||
$url =~ s/\/+/\//g;
|
||||
if ($self->session->setting->get("preventProxyCache") == 1 and !$skipPreventProxyCache) {
|
||||
$url = $self->append($url,"noCache=".randint(0,1000).':'.time());
|
||||
}
|
||||
if ($pairs) {
|
||||
$url = $self->append($url,$pairs);
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getBackToSiteURL ( )
|
||||
|
||||
Tries to return a URL to take the user back to the last page they were at before
|
||||
using an operation or other function. This will always include the gateway
|
||||
url from the config file.
|
||||
|
||||
=cut
|
||||
|
||||
sub getBackToSiteURL {
|
||||
my $self = shift;
|
||||
my $url;
|
||||
if (defined $self->session->asset) {
|
||||
my $importNode = WebGUI::Asset->getImportNode($self->session);
|
||||
my $importNodeLineage = $importNode->get("lineage");
|
||||
my $media = WebGUI::Asset->getMedia($self->session);
|
||||
my $mediaLineage = $media->get("lineage");
|
||||
my $assetLineage = $self->session->asset->get("lineage");
|
||||
if ( $assetLineage =~ /^$importNodeLineage/
|
||||
|| $assetLineage eq "000001"
|
||||
|| $assetLineage =~ /^$mediaLineage/
|
||||
|| $self->session->asset->get("state") ne "published" ##Parent state is okay be definition
|
||||
) {
|
||||
$url = WebGUI::Asset->getDefault($self->session)->getUrl;
|
||||
}
|
||||
else {
|
||||
my $container = $self->session->asset->getContainer;
|
||||
##Container may be under a different version tag if this asset has been moved.
|
||||
if (defined $container) {
|
||||
$url = $container->getUrl;
|
||||
}
|
||||
else {
|
||||
$url = $self->session->url->page();
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$url = $self->session->url->page();
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getRawUrl ( )
|
||||
|
||||
Gets the URL from the request object and decodes it from UTF8. This has the gateway and
|
||||
query and fragment parts.
|
||||
|
||||
=cut
|
||||
|
||||
sub getRawUrl {
|
||||
my $self = shift;
|
||||
unless ($self->{_rawUrl}) {
|
||||
$self->{_rawUrl} = decode_utf8($self->session->request->uri);
|
||||
}
|
||||
return $self->{_rawUrl};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getRefererUrl ( )
|
||||
|
||||
Returns the URL of the page this request was refered from (no gateway, no query params, just the page url). Returns undef if there was no referer.
|
||||
|
||||
=cut
|
||||
|
||||
sub getRefererUrl {
|
||||
my $self = shift;
|
||||
my $referer = $self->session->env->get("HTTP_REFERER");
|
||||
return undef unless ($referer);
|
||||
my $url = $referer;
|
||||
my $gateway = $self->session->config->get("gateway");
|
||||
$url =~ s{https?://[A-Za-z0-9\.-]+$gateway/*([^?]*)\??.*$}{$1};
|
||||
if ($url eq $referer) { ##s/// failed
|
||||
return undef;
|
||||
} else {
|
||||
return $url;
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 forceSecureConnection( url )
|
||||
|
||||
Attempts to create an SSL connection with the current or passed in url. Returns 1
|
||||
if it was forced to use SSL. Returns 0 if it wasn't.
|
||||
|
||||
When this method returns 1, the calling method should return the 'redirect' flag.
|
||||
|
||||
=head3 url
|
||||
|
||||
The optional url that the page should forward to as an SSL connection. If the URL
|
||||
is not passed in, it will attempt to get one from the L<page> method, or finally from %ENV.
|
||||
|
||||
=cut
|
||||
|
||||
sub forceSecureConnection {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my ($conf, $env, $http) = $self->session->quick(qw(config env http));
|
||||
|
||||
if ($conf->get("sslEnabled") && !$env->sslRequest){
|
||||
|
||||
$url = $self->session->url->page if(! $url);
|
||||
$url = $env->get('QUERY_STRING') if(! $url);
|
||||
|
||||
my $siteURL = $self->getSiteURL();
|
||||
|
||||
if($url !~ /^$siteURL/i){
|
||||
$url = $siteURL . $url;
|
||||
}
|
||||
if($env->get('QUERY_STRING')){
|
||||
$url .= "?". $env->get('QUERY_STRING');
|
||||
}
|
||||
if($url =~ /^http/i) {
|
||||
$url =~ s/^https?/https/i;
|
||||
$http->setRedirect($url);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getRequestedUrl ( )
|
||||
|
||||
Returns the URL of the page requested (no gateway, no query params, just the page url).
|
||||
|
||||
=cut
|
||||
|
||||
sub getRequestedUrl {
|
||||
my $self = shift;
|
||||
return undef unless ($self->session->request);
|
||||
unless ($self->{_requestedUrl}) {
|
||||
$self->{_requestedUrl} = decode_utf8($self->session->request->uri);
|
||||
my $gateway = $self->session->config->get("gateway");
|
||||
$self->{_requestedUrl} =~ s/^$gateway([^?]*)\??.*$/$1/;
|
||||
}
|
||||
return $self->{_requestedUrl};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getSiteURL ( )
|
||||
|
||||
Returns a constructed site url without the gateway. The returned value can be overridden using the setSiteURL function.
|
||||
|
||||
=cut
|
||||
|
||||
sub getSiteURL {
|
||||
my $self = shift;
|
||||
unless ($self->{_siteUrl}) {
|
||||
my $site = "";
|
||||
my $sitenames = $self->session->config->get("sitename");
|
||||
my ($http_host,$currentPort) = split(':', $self->session->env->get("HTTP_HOST"));
|
||||
if ($self->session->setting->get("hostToUse") eq "HTTP_HOST" and isIn($http_host,@{$sitenames})) {
|
||||
$site = $http_host;
|
||||
} else {
|
||||
$site = $sitenames->[0];
|
||||
}
|
||||
my $proto = "http://";
|
||||
if ($self->session->env->sslRequest) {
|
||||
$proto = "https://";
|
||||
}
|
||||
my $port = "";
|
||||
$port = ":".$self->session->config->get("webServerPort") if ($self->session->config->get("webServerPort"));
|
||||
$self->{_siteUrl} = $proto.$site.$port;
|
||||
}
|
||||
return $self->{_siteUrl};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 makeAbsolute ( url , [ baseURL ] )
|
||||
|
||||
Returns an absolute url.
|
||||
|
||||
=head3 url
|
||||
|
||||
The url to make absolute.
|
||||
|
||||
=head3 baseURL
|
||||
|
||||
The base URL to use. This defaults to current page url.
|
||||
|
||||
=cut
|
||||
|
||||
sub makeAbsolute {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my $baseURL = shift;
|
||||
$baseURL = $self->page() unless $baseURL;
|
||||
return URI->new_abs($url,$baseURL);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 makeCompliant ( string )
|
||||
|
||||
Returns a string that has been made into a WebGUI compliant URL.
|
||||
|
||||
=head3 string
|
||||
|
||||
The string to make compliant. This is usually a page title or a filename.
|
||||
|
||||
=cut
|
||||
|
||||
sub makeCompliant {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
$url =~ s{^\s+}{}; # remove leading whitespace
|
||||
$url =~ s{\s+$}{}; # remove trailing whitespace
|
||||
$url =~ s{^/+}{}; # remove leading slashes
|
||||
$url =~ s{/+$}{}; # remove trailing slashes
|
||||
$url =~ s{[^\w/:.-]+}{-}g; # replace anything aside from word or other allowed characters with dashes
|
||||
$url =~ tr{/-}{/-}s; # replace multiple slashes and dashes with singles.
|
||||
return $url;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
||||
Constructor.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 page ( [ pairs, useSiteUrl, skipPreventProxyCache ] )
|
||||
|
||||
Returns the URL of the current page, including the configured site gateway.
|
||||
|
||||
=head3 pairs
|
||||
|
||||
Name and value pairs as a string to add to the URL that will be returned.
|
||||
|
||||
name1=value1;name2=value2;name3=value3
|
||||
|
||||
=head3 useSiteUrl
|
||||
|
||||
If set to "1" we'll use the full site URL rather than the script (gateway) URL.
|
||||
|
||||
=head3 skipPreventProxyCache
|
||||
|
||||
If preventing proxy caching is enabled in the settings, then if
|
||||
skipPreventProxyCache is a 1 it will prevent the code that prevents
|
||||
proxy caching from being added. If that doesn't make your head hurt
|
||||
then you'll understand the rest of wG just fine.
|
||||
|
||||
=cut
|
||||
|
||||
sub page {
|
||||
my $self = shift;
|
||||
my $pairs = shift;
|
||||
my $useFullUrl = shift;
|
||||
my $skipPreventProxyCache = shift;
|
||||
my $url;
|
||||
if ($useFullUrl) {
|
||||
$url = $self->getSiteURL();
|
||||
}
|
||||
my $path = $self->session->asset ? $self->session->asset->get("url") : URI::Escape::uri_escape_utf8($self->getRequestedUrl, "^A-Za-z0-9\-_.!~*'()/");
|
||||
$url .= $self->gateway($path, $pairs, $skipPreventProxyCache);
|
||||
return $url;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setSiteURL ( )
|
||||
|
||||
Sets an alternate site url for this session variable.
|
||||
|
||||
=cut
|
||||
|
||||
sub setSiteURL {
|
||||
my $self = shift;
|
||||
$self->{_siteUrl} = shift;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 unescape
|
||||
|
||||
Decodes a string that was URL encoded.
|
||||
|
||||
B<NOTE:> See $self->session->url->escape()
|
||||
|
||||
=head3 string
|
||||
|
||||
The string to unescape.
|
||||
|
||||
=cut
|
||||
|
||||
sub unescape {
|
||||
my $self = shift;
|
||||
return uri_unescape(shift);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 urlize ( string )
|
||||
|
||||
Returns a url that is safe for WebGUI pages. Strings are lower-cased, run through
|
||||
$self->makeCompliant and then have any relative segments and trailing slashes removed.
|
||||
|
||||
=head3 string
|
||||
|
||||
The string to urlize.
|
||||
|
||||
=cut
|
||||
|
||||
sub urlize {
|
||||
my $self = shift;
|
||||
my $value = lc(shift); #lower cases whole string
|
||||
$value = $self->makeCompliant($value);
|
||||
|
||||
# remove /./ or /../
|
||||
$value =~ s{(^|/)(?:\.\.?/)*}{$1}g;
|
||||
|
||||
# remove trailing slashes
|
||||
return $value;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
289
lib/WebGUI/Session/Var.pm
Normal file
289
lib/WebGUI/Session/Var.pm
Normal file
|
|
@ -0,0 +1,289 @@
|
|||
package WebGUI::Session::Var;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2009 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 Scalar::Util qw( weaken );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::Var
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package is the persistence layer for WebGUI session variables.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$var = WebGUI::Session::Var->new($session);
|
||||
|
||||
$value = $var->get('lastIP');
|
||||
|
||||
$var->start;
|
||||
$var->end;
|
||||
|
||||
$boolean = $var->isAdminOn;
|
||||
|
||||
$var->switchAdminOff;
|
||||
$var->switchAdminOn;
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 end ( )
|
||||
|
||||
Removes the specified user session from memory and database.
|
||||
|
||||
=cut
|
||||
|
||||
sub end {
|
||||
my $self = shift;
|
||||
$self->session->scratch->deleteAll;
|
||||
$self->session->db->write("delete from userSession where sessionId=?",[$self->getId]);
|
||||
delete $self->session->{_user};
|
||||
$self->DESTROY;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( varName )
|
||||
|
||||
Retrieves the current value of a session variable.
|
||||
|
||||
=head3 varName
|
||||
|
||||
The name of the variable.
|
||||
|
||||
=head4 lastIP
|
||||
|
||||
The last IP address the user came from.
|
||||
|
||||
=head4 lastPageView
|
||||
|
||||
The epoch date of the last interaction with the session.
|
||||
|
||||
=head4 userId
|
||||
|
||||
The unique id of the user this session currently bound to.
|
||||
|
||||
=head4 adminOn
|
||||
|
||||
A boolean indicating whether this session has admin mode enabled or not.
|
||||
|
||||
=head4 sessionId
|
||||
|
||||
The sessionId associated with this session.
|
||||
|
||||
=head4 expires
|
||||
|
||||
The epoch date when this user session will expire if it's not accessed again by then.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
return $self->{_var}{$var};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getId ( )
|
||||
|
||||
Returns the ID of the current session.
|
||||
|
||||
=cut
|
||||
|
||||
sub getId {
|
||||
my $self = shift;
|
||||
$self->get("sessionId");
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 isAdminOn ( )
|
||||
|
||||
Returns a boolean indicating whether admin mode is on or not.
|
||||
|
||||
=cut
|
||||
|
||||
sub isAdminOn {
|
||||
my $self = shift;
|
||||
return $self->get("adminOn");
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, sessionId, noFuss )
|
||||
|
||||
Constructor. Overwrites the sessionId of $session with its own id. Returns a var object.
|
||||
|
||||
=head3 session
|
||||
|
||||
A reference to the session.
|
||||
|
||||
=head3 sessionId
|
||||
|
||||
The specific sessionId you want to instantiate.
|
||||
|
||||
=head3 noFuss
|
||||
|
||||
A boolean, that if true will not update the session, or check if it's
|
||||
expired. This is mainly for WebGUI session maintenance, and shouldn't
|
||||
normally be used by anyone.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken( $self->{_session} );
|
||||
my $sessionId = shift;
|
||||
my $noFuss = shift;
|
||||
if ($sessionId eq "") { ##New session
|
||||
$self->start(1);
|
||||
}
|
||||
else { ##existing session requested
|
||||
$self->{_var} = $session->db->quickHashRef("select * from userSession where sessionId=?",[$sessionId]);
|
||||
##We have to make sure that the session variable has a sessionId, otherwise downstream users of
|
||||
##the object will break
|
||||
if ($noFuss && $self->{_var}{sessionId}) {
|
||||
$self->session->{_sessionId} = $self->{_var}{sessionId};
|
||||
return $self;
|
||||
}
|
||||
if ($self->{_var}{expires} && $self->{_var}{expires} < time()) { ##Session expired, start a new one with the same Id
|
||||
$self->end;
|
||||
$self->start(1,$sessionId);
|
||||
}
|
||||
elsif ($self->{_var}{sessionId} ne "") { ##Fetched an existing session. Update variables with recent data.
|
||||
$self->{_var}{lastPageView} = time();
|
||||
$self->{_var}{lastIP} = $session->env->getIp;
|
||||
$self->{_var}{expires} = time() + $session->setting->get("sessionTimeout");
|
||||
$self->session->{_sessionId} = $self->{_var}{sessionId};
|
||||
$session->db->setRow("userSession","sessionId",$self->{_var});
|
||||
return $self;
|
||||
}
|
||||
else { ##Start a new default session with the requested, non-existant id.
|
||||
$self->start(1,$sessionId);
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns a reference to the session object.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 start ( [ userId, sessionId ] )
|
||||
|
||||
Start a new user session. Returns the user session id. The session variable's sessionId
|
||||
is set to the var object's session id. Also sets the user's CSRF token.
|
||||
|
||||
=head3 userId
|
||||
|
||||
The user id of the user to create a session for. Defaults to 1 (Visitor).
|
||||
|
||||
=head3 sessionId
|
||||
|
||||
Session id will be generated if not specified. In almost every case you should let the system generate the session id.
|
||||
|
||||
=cut
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
my $userId = shift;
|
||||
$userId = 1 if ($userId eq "");
|
||||
my $sessionId = shift;
|
||||
$sessionId = $self->session->id->generate if ($sessionId eq "");
|
||||
my $time = time();
|
||||
$self->{_var} = {
|
||||
expires => $time + $self->session->setting->get("sessionTimeout"),
|
||||
lastPageView => $time,
|
||||
lastIP => $self->session->env->getIp,
|
||||
adminOn => 0,
|
||||
userId => $userId
|
||||
};
|
||||
$self->{_var}{sessionId} = $sessionId;
|
||||
$self->session->db->setRow("userSession","sessionId",$self->{_var},$sessionId);
|
||||
$self->session->{_sessionId} = $sessionId;
|
||||
$self->session->scratch->set('webguiCsrfToken', $self->session->id->generate);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 switchAdminOff ( )
|
||||
|
||||
Disables admin mode.
|
||||
|
||||
=cut
|
||||
|
||||
sub switchAdminOff {
|
||||
my $self = shift;
|
||||
$self->{_var}{adminOn} = 0;
|
||||
$self->session->db->setRow("userSession","sessionId", $self->{_var});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 switchAdminOn ( )
|
||||
|
||||
Enables admin mode.
|
||||
|
||||
=cut
|
||||
|
||||
sub switchAdminOn {
|
||||
my $self = shift;
|
||||
$self->{_var}{adminOn} = 1;
|
||||
$self->session->db->setRow("userSession","sessionId", $self->{_var});
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue