Merge branch 'psgi' into WebGUI8
This commit is contained in:
Graham Knop
commit
89d4f46a18
94 changed files with 2002 additions and 2269 deletions
|
|
@ -106,19 +106,6 @@ sub delete {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 displayImpression ( dontCount )
|
||||
|
||||
Finds out what the next ad is to display, increments it's impression counter, and returns the HTML to display it.
|
||||
|
|
|
|||
|
|
@ -96,19 +96,6 @@ sub delete {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( name )
|
||||
|
||||
Returns the value of a property.
|
||||
|
|
|
|||
|
|
@ -721,8 +721,8 @@ sub fixUrl {
|
|||
# fix urls used by uploads and extras
|
||||
# and those beginning with http
|
||||
my @badUrls = (
|
||||
$self->session->config->get("extrasURL"),
|
||||
$self->session->config->get("uploadsURL"),
|
||||
$self->session->url->make_urlmap_work($self->session->config->get("extrasURL")),
|
||||
$self->session->url->make_urlmap_work($self->session->config->get("uploadsURL")),
|
||||
);
|
||||
foreach my $badUrl (@badUrls) {
|
||||
$badUrl =~ s{ / $ }{}x; # Remove trailing slashes from the end of the URL
|
||||
|
|
@ -2069,7 +2069,7 @@ sub outputWidgetMarkup {
|
|||
my $assetId = $self->getId;
|
||||
my $hexId = $session->id->toHex($assetId);
|
||||
my $conf = $session->config;
|
||||
my $extras = $conf->get('extrasURL');
|
||||
my $extras = $session->url->make_urlmap_work($conf->get('extrasURL'));
|
||||
|
||||
# the widgetized version of content that has the widget macro in it is
|
||||
# executing in an iframe. this iframe doesn't have a style object.
|
||||
|
|
@ -2171,7 +2171,7 @@ sub prepareWidgetView {
|
|||
my $self = shift;
|
||||
my $templateId = shift;
|
||||
my $template = WebGUI::Asset::Template->newById($self->session, $templateId);
|
||||
my $extras = $self->session->config->get('extrasURL');
|
||||
my $extras = $self->session->url->make_urlmap_work($self->session->config->get('extrasURL'));
|
||||
|
||||
$template->prepare;
|
||||
|
||||
|
|
|
|||
|
|
@ -598,7 +598,7 @@ sub process {
|
|||
}
|
||||
|
||||
# Return a JSONinfied version of vars if JSON is the only requested content type.
|
||||
if ( defined $session->request && $session->request->headers_in->{Accept} eq 'application/json' ) {
|
||||
if ( defined $session->request && $session->request->header('Accept') eq 'application/json' ) {
|
||||
$session->http->setMimeType( 'application/json' );
|
||||
return to_json( $vars );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -313,7 +313,6 @@ sub view {
|
|||
|
||||
my @found;
|
||||
my $newStuff;
|
||||
my $showPerformance = $self->session->errorHandler->canShowPerformanceIndicators();
|
||||
foreach my $position (@positions) {
|
||||
my @assets = split(",",$position);
|
||||
foreach my $asset (@assets) {
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@ use WebGUI::International;
|
|||
use WebGUI::Storage;
|
||||
use WebGUI::Asset::Wobject::HttpProxy::Parse;
|
||||
use WebGUI::Macro;
|
||||
use Apache2::Upload;
|
||||
use Tie::IxHash;
|
||||
|
||||
use Moose;
|
||||
|
|
@ -443,7 +442,7 @@ sub view {
|
|||
}
|
||||
my $p = WebGUI::Asset::Wobject::HttpProxy::Parse->new($self->session, $proxiedUrl, $var{content}, $self->getId,$self->rewriteUrls,$self->getUrl,$self->urlPatternFilter);
|
||||
$var{content} = $p->filter; # Rewrite content. (let forms/links return to us).
|
||||
$p->DESTROY;
|
||||
undef $p;
|
||||
|
||||
if ($var{content} =~ /<frame/gis) {
|
||||
$var{header} = "text/html";
|
||||
|
|
|
|||
|
|
@ -50,11 +50,6 @@ my %tag_attr = (
|
|||
"script src" => 1
|
||||
);
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self = undef;
|
||||
}
|
||||
|
||||
=head2 new ( $class, $session)
|
||||
|
||||
Constructor for parser.
|
||||
|
|
|
|||
|
|
@ -327,7 +327,7 @@ Show performance indicators for the Layout and all children if enabled.
|
|||
sub view {
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
my $showPerformance = $session->errorHandler->canShowPerformanceIndicators;
|
||||
my $perfLog = $session->log->performanceLogger;
|
||||
my @parts = split $self->{_viewSplitter},
|
||||
$self->processTemplate($self->{_viewVars}, undef, $self->{_viewTemplate});
|
||||
my $output = "";
|
||||
|
|
@ -342,9 +342,10 @@ sub view {
|
|||
my ($assetId, $outputPart) = split '~~', $part, 2;
|
||||
my $asset = $self->{_viewPlaceholder}{$assetId};
|
||||
if (defined $asset) {
|
||||
my $t = [Time::HiRes::gettimeofday()] if ($showPerformance);
|
||||
my $t = $perfLog ? [Time::HiRes::gettimeofday()] : undef;
|
||||
my $assetOutput = $asset->view;
|
||||
$assetOutput .= "Asset:".Time::HiRes::tv_interval($t) if ($showPerformance);
|
||||
$perfLog->({ asset => $asset, 'time' => Time::HiRes::tv_interval($t), type => 'Layout' })
|
||||
if $perfLog;
|
||||
if ($self->{_viewPrintOverride}) {
|
||||
$session->output->print($assetOutput);
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -728,7 +728,7 @@ sub view {
|
|||
my $config = $session->config;
|
||||
my $eh = $session->errorHandler;
|
||||
|
||||
$var->{'extras'} = $config->get("extrasURL")."/wobject/ProjectManager";
|
||||
$var->{'extras'} = $session->url->make_urlmap_work($config->get("extrasURL"))."/wobject/ProjectManager";
|
||||
$var->{'project.create'} = $self->getUrl("func=editProject;projectId=new");
|
||||
$var->{'project.create.label'} = $i18n->get("project new label");
|
||||
|
||||
|
|
@ -891,7 +891,7 @@ sub www_drawGanttChart {
|
|||
|
||||
my ($dunits,$hoursPerDay) = $db->quickArray("select durationUnits,hoursPerDay from PM_project where projectId=".$db->quote($projectId));
|
||||
|
||||
$var->{'extras'} = $config->get("extrasURL")."/wobject/ProjectManager";
|
||||
$var->{'extras'} = $session->url->make_urlmap_work($config->get("extrasURL"))."/wobject/ProjectManager";
|
||||
|
||||
#Initialize display settings
|
||||
my $projectDisplay = "weeks";
|
||||
|
|
@ -1481,8 +1481,8 @@ sub www_editTask {
|
|||
});
|
||||
$var->{'form.footer'} = WebGUI::Form::formFooter($session);
|
||||
|
||||
$var->{'extras'} = $config->get("extrasURL");
|
||||
$var->{'assetExtras'} = $config->get("extrasURL").'/wobject/ProjectManager';
|
||||
$var->{'extras'} = $session->url->make_urlmap_work($config->get("extrasURL"));
|
||||
$var->{'assetExtras'} = $session->url->make_urlmap_work($config->get("extrasURL")).'/wobject/ProjectManager';
|
||||
|
||||
$var->{'task_name_label'} = $i18n->get('task name label');
|
||||
$var->{'task_start_label'} = $i18n->get('task start label');
|
||||
|
|
@ -1713,8 +1713,8 @@ sub www_viewProject {
|
|||
return $privilege->insufficient unless $self->_userCanObserveProject($user, $projectId);
|
||||
|
||||
#Set extras template variables
|
||||
my $extras = $config->get("extrasURL");
|
||||
my $assetExtras = $config->get("extrasURL")."/wobject/ProjectManager";
|
||||
my $extras = $session->url->make_urlmap_work($config->get("extrasURL"));
|
||||
my $assetExtras = $session->url->make_urlmap_work($config->get("extrasURL"))."/wobject/ProjectManager";
|
||||
$var->{'extras' } = $assetExtras;
|
||||
$var->{'extras.base'} = $extras;
|
||||
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ sub view {
|
|||
|
||||
my ($session,$privilege,$form,$db,$dt,$user,$eh,$config) = $self->getSessionVars("privilege","form","db","datetime","user","errorHandler","config");
|
||||
my $i18n = WebGUI::International->new($session,'Asset_TimeTracking');
|
||||
$var->{'extras'} = $config->get("extrasURL")."/wobject/TimeTracking";
|
||||
$var->{'extras'} = $session->url->make_urlmap_work($config->get("extrasURL"))."/wobject/TimeTracking";
|
||||
|
||||
if($user->isInGroup($self->groupToManage)) {
|
||||
$var->{'project.manage.url'} = $self->getUrl("func=manageProjects");
|
||||
|
|
@ -324,7 +324,7 @@ sub www_editProject {
|
|||
return $privilege->insufficient unless ($user->isInGroup($self->groupToManage));
|
||||
my $projectId = $_[0] || $form->get("projectId") || "new";
|
||||
my $taskError = qq|<br><span style="color:red;font-weight:bold">$_[1]</span>| if($_[1]);
|
||||
my $extras = $config->get("extrasURL")."/wobject/TimeTracking";
|
||||
my $extras = $session->url->make_urlmap_work($config->get("extrasURL"))."/wobject/TimeTracking";
|
||||
|
||||
my $project = $db->quickHashRef("select * from TT_projectList where projectId=".$db->quote($projectId));
|
||||
#Build Form
|
||||
|
|
@ -496,7 +496,7 @@ sub www_manageProjects {
|
|||
my $pnLabel = $i18n->get("manage project name label");
|
||||
my $atLabel = $i18n->get("manage project available task label");
|
||||
my $resLabel = $i18n->get("manage project resource label");
|
||||
my $extras = $config->get("extrasURL")."/wobject/TimeTracking";
|
||||
my $extras = $session->url->make_urlmap_work($config->get("extrasURL"))."/wobject/TimeTracking";
|
||||
my $errorMessage = "";
|
||||
$errorMessage = qq|<span style="color:red;font-weight:bold">$_[0]</span>| if($_[0]);
|
||||
|
||||
|
|
|
|||
|
|
@ -630,9 +630,9 @@ sub exportSymlinkExtrasUploads {
|
|||
|
||||
my $config = $session->config;
|
||||
my $extrasPath = $config->get('extrasPath');
|
||||
my $extrasUrl = $config->get('extrasURL');
|
||||
my $extrasUrl = $session->url->make_urlmap_work($config->get('extrasURL'));
|
||||
my $uploadsPath = $config->get('uploadsPath');
|
||||
my $uploadsUrl = $config->get('uploadsURL');
|
||||
my $uploadsUrl = $session->url->make_urlmap_work($config->get('uploadsURL'));
|
||||
|
||||
# we have no assurance whether the exportPath is valid or not, so check it.
|
||||
my $exportPath = WebGUI::Asset->exportCheckPath($session);
|
||||
|
|
|
|||
|
|
@ -20,8 +20,6 @@ use Time::HiRes;
|
|||
use WebGUI::Asset;
|
||||
use WebGUI::PassiveAnalytics::Logging;
|
||||
|
||||
use Apache2::Const -compile => qw(OK);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Content::MyHandler
|
||||
|
|
@ -85,28 +83,11 @@ sub handler {
|
|||
my ($session) = @_;
|
||||
my ($errorHandler, $http, $var, $asset, $request, $config) = $session->quick(qw(errorHandler http var asset request config));
|
||||
my $output = "";
|
||||
if ($errorHandler->canShowPerformanceIndicators) { #show performance indicators if required
|
||||
if (my $perfLog = $errorHandler->performanceLogger) { #show performance indicators if required
|
||||
my $t = [Time::HiRes::gettimeofday()];
|
||||
$output = page($session);
|
||||
$t = Time::HiRes::tv_interval($t) ;
|
||||
if ($output =~ /<\/title>/) {
|
||||
$output =~ s/<\/title>/ : ${t} seconds<\/title>/i;
|
||||
}
|
||||
else {
|
||||
# Kludge.
|
||||
my $mimeType = $http->getMimeType();
|
||||
if ($mimeType eq 'text/css') {
|
||||
$session->output->print("\n/* Page generated in $t seconds. */\n");
|
||||
}
|
||||
elsif ($mimeType =~ m{text/html}) {
|
||||
$session->output->print("\nPage generated in $t seconds.\n");
|
||||
}
|
||||
else {
|
||||
# Don't apply to content when we don't know how
|
||||
# to modify it semi-safely.
|
||||
}
|
||||
}
|
||||
}
|
||||
$perfLog->({ time => Time::HiRes::tv_interval($t), type => 'Page'});
|
||||
}
|
||||
else {
|
||||
|
||||
my $asset = getAsset($session, getRequestedAssetUrl($session));
|
||||
|
|
@ -117,7 +98,6 @@ sub handler {
|
|||
&& !$http->ifModifiedSince($asset->getContentLastModified, $session->setting->get('maxCacheTimeout'))) {
|
||||
$http->setStatus("304","Content Not Modified");
|
||||
$http->sendHeader;
|
||||
$session->close;
|
||||
return "chunked";
|
||||
}
|
||||
|
||||
|
|
@ -132,8 +112,7 @@ sub handler {
|
|||
my $ct = guess_media_type($filename);
|
||||
my $oldContentType = $request->content_type($ct);
|
||||
if ($request->sendfile($filename) ) {
|
||||
$session->close;
|
||||
return Apache2::Const::OK;
|
||||
return; # TODO - what should we return to indicate streaming?
|
||||
}
|
||||
else {
|
||||
$request->content_type($oldContentType);
|
||||
|
|
|
|||
|
|
@ -213,7 +213,6 @@ sub disconnect {
|
|||
if (defined $self->{_dbh}) {
|
||||
$self->{_dbh}->disconnect() unless ($self->getId eq "0");
|
||||
}
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -15,50 +15,6 @@ package WebGUI::Exception;
|
|||
=cut
|
||||
|
||||
use strict;
|
||||
use Exception::Class (
|
||||
|
||||
'WebGUI::Error' => {
|
||||
description => "A general error occured.",
|
||||
},
|
||||
'WebGUI::Error::OverrideMe' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => 'This method should be overridden by subclasses.',
|
||||
},
|
||||
'WebGUI::Error::MethodNotFound' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => q|Called a method that doesn't exist.|,
|
||||
fields => 'method'
|
||||
},
|
||||
'WebGUI::Error::InvalidObject' => {
|
||||
isa => 'WebGUI::Error::InvalidParam',
|
||||
description => "Expected to get a reference to an object type that wasn't gotten.",
|
||||
fields => ["expected","got"],
|
||||
},
|
||||
'WebGUI::Error::InvalidParam' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => "Expected to get a param we didn't get.",
|
||||
fields => ["param"],
|
||||
},
|
||||
'WebGUI::Error::ObjectNotFound' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => "The object you were trying to retrieve does not exist.",
|
||||
fields => ["id"],
|
||||
},
|
||||
'WebGUI::Error::ObjectNotFound::Template' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => "The template an asset was trying to retrieve does not exist.",
|
||||
fields => [qw/templateId assetId/],
|
||||
},
|
||||
'WebGUI::Error::InvalidFile' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => "The file you have provided has errors.",
|
||||
fields => [qw{ brokenFile brokenLine }],
|
||||
},
|
||||
'WebGUI::Error::Template' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => "A template has errors that prevent it from being processed.",
|
||||
},
|
||||
);
|
||||
|
||||
sub WebGUI::Error::full_message {
|
||||
my $self = shift;
|
||||
|
|
@ -319,6 +275,15 @@ use Exception::Class (
|
|||
fields => [qw{ resource }],
|
||||
},
|
||||
|
||||
'WebGUI::Error::Fatal' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => "Fatal error that should be shown to all site visitors.",
|
||||
},
|
||||
|
||||
'WebGUI::Error::Database' => {
|
||||
isa => 'WebGUI::Error',
|
||||
description => 'A database error',
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ package WebGUI::FormValidator;
|
|||
use strict qw(vars subs);
|
||||
use WebGUI::HTML;
|
||||
use WebGUI::Pluggable;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -79,20 +80,8 @@ sub AUTOLOAD {
|
|||
return $control->getValue(@args);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
# so it doesn't get autoloaded
|
||||
sub DESTROY {}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
|
|
@ -120,9 +109,11 @@ A reference to the current session.
|
|||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -271,7 +271,6 @@ sub delete {
|
|||
$self->session->db->write("delete from groups where groupId=?", [$self->getId]);
|
||||
$self->session->db->write("delete from groupings where groupId=?", [$self->getId]);
|
||||
$self->session->db->write("delete from groupGroupings where inGroup=? or groupId=?", [$self->getId, $self->getId]);
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -364,21 +363,6 @@ sub description {
|
|||
return $self->get("description");
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY
|
||||
|
||||
Desconstructor
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 expireNotify ( [ value ] )
|
||||
|
|
|
|||
|
|
@ -91,20 +91,6 @@ sub AUTOLOAD {
|
|||
$self->{_data} .= $control->toHtmlWithWrapper;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Disposes of the form object.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self = undef;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 dynamicForm ( $formDefinition, $listName, $who )
|
||||
|
|
|
|||
|
|
@ -119,19 +119,6 @@ sub canRead {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getMessage ( messageId [, userId] )
|
||||
|
||||
Returns a WebGUI::Inbox::Message object.
|
||||
|
|
|
|||
|
|
@ -260,19 +260,6 @@ sub delete {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( property )
|
||||
|
||||
Returns the value of a property.
|
||||
|
|
|
|||
|
|
@ -121,10 +121,10 @@ sub connectToLDAP {
|
|||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self->unbind;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -43,7 +43,8 @@ Defaults to 'url'. But if you want to use an assetId as the first parameter, the
|
|||
#-------------------------------------------------------------------
|
||||
sub process {
|
||||
my ($session, $identifier, $type) = @_;
|
||||
my $t = ($session->errorHandler->canShowPerformanceIndicators()) ? [Time::HiRes::gettimeofday()] : undef;
|
||||
my $perfLog = $session->log->performanceLogger;
|
||||
my $t = $perfLog ? [Time::HiRes::gettimeofday()] : undef;
|
||||
my $asset;
|
||||
if ($type eq 'assetId') {
|
||||
$asset = eval { WebGUI::Asset->newById($session, $identifier); };
|
||||
|
|
@ -79,8 +80,8 @@ sub process {
|
|||
$asset->toggleToolbar;
|
||||
$asset->prepareView;
|
||||
my $output = $asset->view;
|
||||
$output .= "AssetProxy:" . Time::HiRes::tv_interval($t)
|
||||
if $t;
|
||||
$perfLog->({ asset => $asset, time => Time::HiRes::tv_interval($t), type => 'Proxy'})
|
||||
if $perfLog;
|
||||
return $output;
|
||||
}
|
||||
return '';
|
||||
|
|
|
|||
|
|
@ -92,8 +92,8 @@ sub process {
|
|||
|
||||
my $uploadsDir = Path::Class::Dir->new($session->config->get('uploadsPath'));
|
||||
my $extrasDir = Path::Class::Dir->new($session->config->get('extrasPath'));
|
||||
my $uploadsUrl = Path::Class::Dir->new($session->config->get('uploadsURL'));
|
||||
my $extrasUrl = Path::Class::Dir->new($session->config->get('extrasURL'));
|
||||
my $uploadsUrl = Path::Class::Dir->new($session->url->make_urlmap_work($session->config->get('uploadsURL')));
|
||||
my $extrasUrl = Path::Class::Dir->new($session->url->make_urlmap_work($session->config->get('extrasURL')));
|
||||
|
||||
##Normal mode
|
||||
if (! $session->var->isAdminOn) {
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ sub process {
|
|||
|
||||
# Get location for CSS and JS files
|
||||
my $conf = $session->config;
|
||||
my $extras = $conf->get("extrasURL");
|
||||
my $extras = $session->url->make_urlmap_work($conf->get("extrasURL"));
|
||||
|
||||
# add CSS and JS to the page
|
||||
my $style = $session->style;
|
||||
|
|
|
|||
77
lib/WebGUI/Middleware/Debug/Performance.pm
Normal file
77
lib/WebGUI/Middleware/Debug/Performance.pm
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
package WebGUI::Middleware::Debug::Performance;
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
use parent qw(Plack::Middleware::Debug::Base);
|
||||
our $VERSION = '0.07';
|
||||
|
||||
sub panel_name { 'Asset Performance' }
|
||||
|
||||
sub run {
|
||||
my ($self, $env, $panel) = @_;
|
||||
|
||||
my $perf_log = [];
|
||||
$env->{'webgui.perf.logger'} = sub {
|
||||
my $args = shift;
|
||||
my $asset = $args->{asset};
|
||||
my $log_data = {
|
||||
'time' => $args->{time},
|
||||
'type' => $args->{type},
|
||||
'message' => $args->{message},
|
||||
$asset ? (
|
||||
'viewUrl' => $asset->getUrl,
|
||||
'editUrl' => $asset->getUrl('func=edit'),
|
||||
'assetTitle' => $asset->title,
|
||||
) : (),
|
||||
};
|
||||
push @$perf_log, $log_data;
|
||||
};
|
||||
|
||||
return sub {
|
||||
my $res = shift;
|
||||
|
||||
$panel->nav_subtitle(scalar @$perf_log . ' events');
|
||||
if (@$perf_log) {
|
||||
$panel->content($self->render_log($perf_log));
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
my $log_template = __PACKAGE__->build_template(<<'EOTMPL');
|
||||
<table>
|
||||
<thead>
|
||||
<tr>
|
||||
<th>Time</th>
|
||||
<th>Type</th>
|
||||
<th>Item</th>
|
||||
</tr>
|
||||
</thead>
|
||||
<tbody>
|
||||
% my $i;
|
||||
% for my $event ( @{ $_[0]->{list} } ) {
|
||||
<tr class="<%= ++$i % 2 ? 'plDebugOdd' : 'plDebugEven' %>">
|
||||
<td><%= $event->{time} %></td>
|
||||
<td><%= $event->{type} %></td>
|
||||
<td>
|
||||
% if ($event->{message}) {
|
||||
<%= $event->{message} %>
|
||||
% }
|
||||
% if ($event->{assetTitle}) {
|
||||
<a href="<%= $event->{viewUrl} %>">View</a>
|
||||
<a href="<%= $event->{editUrl} %>">Edit</a>
|
||||
<%= $event->{assetTitle} %>
|
||||
% }
|
||||
</td>
|
||||
</tr>
|
||||
% }
|
||||
</tbody>
|
||||
</table>
|
||||
EOTMPL
|
||||
|
||||
sub render_log {
|
||||
my ($self, $events) = @_;
|
||||
$self->render($log_template, { list => $events });
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
36
lib/WebGUI/Middleware/HTTPExceptions.pm
Normal file
36
lib/WebGUI/Middleware/HTTPExceptions.pm
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
package WebGUI::Middleware::HTTPExceptions;
|
||||
use strict;
|
||||
use parent qw(Plack::Middleware::HTTPExceptions);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Middleware::HTTPExceptions - Converts Exceptions into HTTP Errors
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is PSGI middleware for WebGUI that detects exceptions and turns
|
||||
them into HTTP Errors. This class is a subclass of L<Plack::Middleware::HTTPExceptions>
|
||||
|
||||
=cut
|
||||
|
||||
use Carp ();
|
||||
use Try::Tiny;
|
||||
use Scalar::Util 'blessed';
|
||||
use HTTP::Status ();
|
||||
|
||||
sub transform_error {
|
||||
my $self = shift;
|
||||
my ($e, $env) = @_;
|
||||
|
||||
# Handle WebGUI::Error::Fatal errors specially, since unlike most 500
|
||||
# errors we actually want the user to see the error message (generated by
|
||||
# $session->log->fatal)
|
||||
if (blessed $e && $e->isa('WebGUI::Error::Fatal')) {
|
||||
my $message = $e->message;
|
||||
return [ 500, [ 'Content-Type' => 'text/html', 'Content-Length' => length($message) ], [ $message ] ];
|
||||
} else {
|
||||
$self->SUPER::transform_error(@_);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
94
lib/WebGUI/Middleware/Session.pm
Normal file
94
lib/WebGUI/Middleware/Session.pm
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
package WebGUI::Middleware::Session;
|
||||
use strict;
|
||||
use parent qw(Plack::Middleware);
|
||||
use WebGUI::Config;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::Utility ();
|
||||
use Try::Tiny;
|
||||
use WebGUI::Middleware::HTTPExceptions;
|
||||
use Plack::Middleware::SimpleLogger;
|
||||
use Plack::Util::Accessor qw( config );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Middleware::Session - Opens and closes the per-request WebGUI::Session
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is PSGI middleware for WebGUI that instantiates, opens and closes the
|
||||
L<WebGUI::Session> object. It does this as early and as late as possible, so
|
||||
that all intermediate middleware (and the WebGUI app itself) can grab
|
||||
the session out of the PSGI env hash:
|
||||
|
||||
$env->{'webgui.session'};
|
||||
|
||||
and not worry about closing it.
|
||||
|
||||
It also sets C<webgui.debug> as appropriate.
|
||||
|
||||
=cut
|
||||
|
||||
sub call {
|
||||
my ( $self, $env ) = @_;
|
||||
|
||||
my $app = $self->app;
|
||||
|
||||
my $config = $self->config or die 'Mandatory config parameter missing';
|
||||
|
||||
# Logger fallback
|
||||
if (!$env->{'psgix.logger'}) {
|
||||
$app = Plack::Middleware::SimpleLogger->wrap( $app );
|
||||
}
|
||||
|
||||
my $session = try {
|
||||
$env->{'webgui.session'} = WebGUI::Session->open( $config, $env );
|
||||
} catch {
|
||||
# We don't have a logger object, so for now just warn() the error
|
||||
warn "Unable to instantiate WebGUI::Session - $_";
|
||||
return; # make sure $session assignment is undef
|
||||
};
|
||||
|
||||
if ( !$session ) {
|
||||
|
||||
# We don't have access to a db connection to find out if the user is allowed to see
|
||||
# a verbose error message or not, so resort to a generic Internal Server Error
|
||||
return [ 500, [ 'Content-Type' => 'text/plain' ], [ 'Internal Server Error' ] ];
|
||||
}
|
||||
|
||||
my $debug = $env->{'webgui.debug'} = $self->canShowDebug($env);
|
||||
|
||||
# Run the app
|
||||
my $res = $app->($env);
|
||||
|
||||
# Use callback style response
|
||||
return $self->response_cb(
|
||||
$res,
|
||||
sub {
|
||||
my $res = shift;
|
||||
|
||||
# Close the Session
|
||||
$env->{'webgui.session'}->close();
|
||||
delete $env->{'webgui.session'};
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub canShowDebug {
|
||||
my $self = shift;
|
||||
my $env = shift;
|
||||
my $session = $env->{'webgui.session'};
|
||||
|
||||
my $canShow = $session->setting->get("showDebug");
|
||||
return
|
||||
unless $canShow;
|
||||
|
||||
my $ips = $session->setting->get('ipDebug');
|
||||
return 1
|
||||
if $ips eq '';
|
||||
$ips =~ s/\s+//g;
|
||||
my @ips = split /,/, $ips;
|
||||
my $ok = WebGUI::Utility::isInSubnet($session->env->getIp, [ @ips ] );
|
||||
return $ok;
|
||||
}
|
||||
|
||||
1;
|
||||
34
lib/WebGUI/Middleware/Snoop.pm
Normal file
34
lib/WebGUI/Middleware/Snoop.pm
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
package WebGUI::Middleware::Snoop;
|
||||
use strict;
|
||||
use parent qw(Plack::Middleware);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Middleware::Snoop - sample middleware port of WebGUI::URL::Snoop
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is PSGI middleware for WebGUI.
|
||||
|
||||
It was ported from L<WebGUI::URL::Snoop>, back when we still had URL handlers.
|
||||
|
||||
L<WebGUI::URL::Snoop> described itself as "A URL handler that should never be called."
|
||||
|
||||
You might find this middleware useful as a template for creating other simple classes.
|
||||
|
||||
=cut
|
||||
|
||||
sub call {
|
||||
my $self = shift;
|
||||
my $env = shift;
|
||||
|
||||
my $path = $env->{PATH_INFO};
|
||||
if ($path =~ qr{^/abcdefghijklmnopqrstuvwxyz$}) {
|
||||
my $snoop = q|<html><head><title>Snoopy</title></head><body><div style="width: 600px; padding: 200px;">Why would you type in this URL? Really. What were you expecting to see here? You really need to get a life. Are you still here? Seriously, you need to go do something else. I think your boss is calling.</div></body></html>|;
|
||||
return [ 200, [ 'Content-Type' => 'text/html' ], [ $snoop ] ];
|
||||
} else {
|
||||
return $self->app->($env);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
70
lib/WebGUI/Middleware/WGAccess.pm
Normal file
70
lib/WebGUI/Middleware/WGAccess.pm
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
package WebGUI::Middleware::WGAccess;
|
||||
use strict;
|
||||
use parent qw(Plack::Middleware);
|
||||
use Path::Class::File;
|
||||
use Scalar::Util;
|
||||
use JSON ();
|
||||
|
||||
=head1 NAME
|
||||
|
||||
WebGUI::Middleware::WGAccess - control access to .wgaccess protected uploads
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is PSGI middleware for WebGUI that delivers static files (uploads) with .wgaccess
|
||||
awareness.
|
||||
|
||||
This middleware should really only be used in development, for production you want
|
||||
to be serving static files with something a lot faster.
|
||||
|
||||
=cut
|
||||
|
||||
sub call {
|
||||
my $self = shift;
|
||||
my $env = shift;
|
||||
my $session = $env->{'webgui.session'};
|
||||
if (! $session) {
|
||||
my $logger = $env->{'psgix.logger'};
|
||||
$logger && $logger->({ level => 'error', message => 'WebGUI session missing!'});
|
||||
return [500, ['Content-Type' => 'text/plain'], 'Internal Server Error'];
|
||||
}
|
||||
|
||||
my $r = $self->app->($env);
|
||||
$self->response_cb($r, sub {
|
||||
my ($status, $headers, $body) = @$r;
|
||||
return
|
||||
unless Scalar::Util::blessed($body) && $body->can('path');
|
||||
|
||||
my $file = Path::Class::File->new($body->path);
|
||||
my $wgaccess = $file->dir->file('.wgaccess');
|
||||
return
|
||||
unless -e $wgaccess;
|
||||
my $contents = $wgaccess->slurp;
|
||||
my $privs;
|
||||
if ($contents =~ /\A(\d+|[A-Za-z0-9_-]{22})\n(\d+|[A-Za-z0-9_-]{22})\n(\d+|[A-Za-z0-9_-]{22})/) {
|
||||
$privs = {
|
||||
users => [ $1 ],
|
||||
groups => [ $2, $3 ],
|
||||
assets => [],
|
||||
};
|
||||
}
|
||||
else {
|
||||
$privs = JSON->new->utf8->decode($contents);
|
||||
}
|
||||
|
||||
require WebGUI::Asset;
|
||||
my $userId = $session->var->get('userId');
|
||||
|
||||
return
|
||||
if grep { $_ eq '1' || $_ eq $userId } @{ $privs->{users} }
|
||||
or grep { $_ eq '1' || $_ eq '7' } @{ $privs->{groups} }
|
||||
or grep { $session->user->isInGroup($_) } @{ $privs->{groups} }
|
||||
or grep { WebGUI::Asset->newById($session, $_)->canView } @{ $privs->{assets} }
|
||||
;
|
||||
|
||||
# failed auto, change response into auth failure
|
||||
@$r = (401, [ 'Content-Type' => 'text/plain' ], [ 'Authorization Required' ]);
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -107,6 +107,7 @@ BEGIN {
|
|||
defaultUploads => catdir($root, 'www', 'uploads'),
|
||||
defaultCreateSQL => catdir($root, 'docs', 'create.sql'),
|
||||
var => catdir($root, 'var'),
|
||||
defaultPSGI => catdir($root, 'var', 'site.psgi'),
|
||||
);
|
||||
my $meta = Class::MOP::Class->initialize(__PACKAGE__);
|
||||
for my $sub (keys %paths) {
|
||||
|
|
|
|||
|
|
@ -15,11 +15,15 @@ package WebGUI::SQL;
|
|||
=cut
|
||||
|
||||
use strict;
|
||||
use DBI;
|
||||
use Tie::IxHash;
|
||||
use WebGUI::SQL::ResultSet;
|
||||
use WebGUI::Utility;
|
||||
use Text::CSV_XS;
|
||||
use DBI ();
|
||||
use Tie::IxHash ();
|
||||
use Text::CSV_XS ();
|
||||
use WebGUI::Utility ();
|
||||
use WebGUI::SQL::ResultSet ();
|
||||
use WebGUI::Exception;
|
||||
use Scalar::Util ();
|
||||
use Try::Tiny;
|
||||
use namespace::clean;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -67,6 +71,94 @@ These methods are available from this package:
|
|||
|
||||
=cut
|
||||
|
||||
our @ISA = qw(DBI);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 connect ( session, dsn, user, pass )
|
||||
|
||||
Constructor. Connects to the database using DBI.
|
||||
|
||||
=head2 session
|
||||
|
||||
A reference to the active WebGUI::Session object.
|
||||
|
||||
=head2 dsn
|
||||
|
||||
The Database Service Name of the database you wish to connect to. It looks like 'DBI:mysql:dbname;host=localhost'.
|
||||
|
||||
=head2 user
|
||||
|
||||
The username to use to connect to the database defined by dsn.
|
||||
|
||||
=head2 pass
|
||||
|
||||
The password to use to connect to the database defined by dsn.
|
||||
|
||||
=cut
|
||||
|
||||
sub connect {
|
||||
my $class = shift;
|
||||
my $session;
|
||||
my $dsn;
|
||||
my $user;
|
||||
my $pass;
|
||||
if (ref $_[0] && $_[0]->isa('WebGUI::Session')) {
|
||||
$session = shift;
|
||||
}
|
||||
if (ref $_[0] && $_[0]->isa('WebGUI::Config')) {
|
||||
my $config = shift;
|
||||
$dsn = $config->get('dsn');
|
||||
$user = $config->get('dbuser');
|
||||
$pass = $config->get('dbpass');
|
||||
}
|
||||
else {
|
||||
$dsn = shift;
|
||||
$user = shift;
|
||||
$pass = shift;
|
||||
}
|
||||
my $params = shift;
|
||||
|
||||
if (! $params) {
|
||||
$params = {};
|
||||
}
|
||||
if (ref $params) {
|
||||
$params = { %$params };
|
||||
}
|
||||
else {
|
||||
my @params = map { split /=/, $_, 2 } split /\n/, $params;
|
||||
for (@params) {
|
||||
s/\s+$//;
|
||||
s/^\s+//;
|
||||
}
|
||||
$params = { @params };
|
||||
}
|
||||
$params->{RaiseError} = 0;
|
||||
$params->{PrintError} = 0;
|
||||
$params->{AutoCommit} = 1;
|
||||
$params->{ShowErrorStatement} = 1;
|
||||
$params->{HandleError} = sub {
|
||||
WebGUI::Error::Database->throw(shift);
|
||||
};
|
||||
if ( ($class->parse_dsn($dsn))[1] eq 'mysql' ) {
|
||||
$params->{mysql_enable_utf8} = 1;
|
||||
}
|
||||
|
||||
my $dbh = $class->SUPER::connect($dsn, $user, $pass, $params);
|
||||
unless (defined $dbh) {
|
||||
die "Couldn't connect to database: $dsn : $DBI::errstr";
|
||||
}
|
||||
if ($session) {
|
||||
$dbh->session($session);
|
||||
}
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
|
||||
package WebGUI::SQL::db;
|
||||
use Try::Tiny;
|
||||
our @ISA = qw(DBI::db);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
|
|
@ -77,8 +169,8 @@ Starts a transaction sequence. To be used with commit and rollback. Any writes a
|
|||
=cut
|
||||
|
||||
sub beginTransaction {
|
||||
my $self = shift;
|
||||
$self->dbh->begin_work;
|
||||
my $self = shift;
|
||||
$self->begin_work;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -104,7 +196,6 @@ sub buildArray {
|
|||
return @{ $arrayRef };
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildArrayRef ( sql, params )
|
||||
|
|
@ -122,16 +213,15 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub buildArrayRef {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
my @array;
|
||||
while (my $data = $sth->arrayRef) {
|
||||
push @array, $data->[0];
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $array = $self->selectall_arrayref($sql, { Slice => [0] }, @$params);
|
||||
for (@$array) {
|
||||
$_ = $_->[0];
|
||||
}
|
||||
return \@array;
|
||||
|
||||
return $array;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -162,7 +252,7 @@ straight hash that is faster but does not maintain order.
|
|||
=cut
|
||||
|
||||
sub buildHash {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
my $hashRef = $self->buildHashRef(@_);
|
||||
return %{ $hashRef };
|
||||
}
|
||||
|
|
@ -195,25 +285,20 @@ straight hash that is faster but does not maintain order.
|
|||
=cut
|
||||
|
||||
sub buildHashRef {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $options = shift || {};
|
||||
my %hash;
|
||||
unless ($options->{noOrder}) {
|
||||
tie %hash, "Tie::IxHash";
|
||||
}
|
||||
$self->session->log->query($sql, $params);
|
||||
my $dbh = $self->dbh;
|
||||
my $results = $dbh->selectall_arrayref($sql, {}, @$params);
|
||||
if ($dbh->err) {
|
||||
$self->session->log->fatal("Couldn't execute prepared statement: $sql : With place holders: ".join(", ", @{$params}).". Root cause: ". $dbh->errstr);
|
||||
tie %hash, 'Tie::IxHash';
|
||||
}
|
||||
my $results = $self->selectall_arrayref($sql, {}, @$params);
|
||||
my $width = @{$results} && @{$results->[0]};
|
||||
%hash
|
||||
= $width == 2 ? map { @{ $_ } } @{ $results }
|
||||
= $width == 2 ? map { @$_ } @{ $results }
|
||||
# for single column, use it for both key and value
|
||||
: $width == 1 ? map { $_->[0], $_->[0] } @{ $results }
|
||||
: $width == 1 ? map { ($_->[0]) x 2 } @{ $results }
|
||||
: $width == 0 ? ()
|
||||
: map {
|
||||
# for more than 2 columns, use all but last joined with colons for key
|
||||
|
|
@ -247,13 +332,8 @@ sub buildArrayRefOfHashRefs {
|
|||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my @array;
|
||||
my $sth = $self->read($sql, $params);
|
||||
while (my $data = $sth->hashRef) {
|
||||
push @array, $data;
|
||||
}
|
||||
$sth->finish;
|
||||
return \@array;
|
||||
my $array = $self->selectall_arrayref($sql, { Slice => {} }, @$params);
|
||||
return $array;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -283,18 +363,21 @@ sub buildDataTableStructure {
|
|||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my %hash;
|
||||
my @array;
|
||||
|
||||
##Note, I need a valid statement handle for doing the rows method on.
|
||||
my $sth = $self->read($sql,$params);
|
||||
while (my $data = $sth->hashRef) {
|
||||
push(@array,$data);
|
||||
}
|
||||
$hash{records} = \@array;
|
||||
$hash{totalRecords} = $self->quickScalar('select found_rows()') + 0; ##Convert to numeric
|
||||
$hash{recordsReturned} = $sth->rows()+0;
|
||||
$sth->finish;
|
||||
return %hash;
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute(@$params);
|
||||
my $array = $sth->fetchall_arrayref( {} );
|
||||
|
||||
my %hash = (
|
||||
records => $array,
|
||||
totalRecords => $self->selectrow_array('SELECT found_rows()') + 0, ##Convert to numeric
|
||||
recordsReturned => $sth->rows + 0,
|
||||
);
|
||||
|
||||
$sth->finish;
|
||||
|
||||
return %hash;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -320,21 +403,21 @@ Which column of the result set to use as the key when creating the hashref.
|
|||
=cut
|
||||
|
||||
sub buildHashRefOfHashRefs {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $key = shift;
|
||||
my $sth = $self->read($sql, $params);
|
||||
my %hash;
|
||||
tie %hash, "Tie::IxHash";
|
||||
while (my $data = $sth->hashRef) {
|
||||
$hash{$data->{$key}} = $data;
|
||||
}
|
||||
$sth->finish;
|
||||
return \%hash;
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $key = shift;
|
||||
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute(@$params);
|
||||
tie my %hash, 'Tie::IxHash';
|
||||
while (my $data = $sth->fetchrow_hashref) {
|
||||
$hash{$data->{$key}} = $data;
|
||||
}
|
||||
$sth->finish;
|
||||
return \%hash;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildSearchQuery ( $sql, $placeholders, $keywords, $columns )
|
||||
|
|
@ -365,7 +448,7 @@ An arrayref of column names that should be searched for $keywords.
|
|||
|
||||
sub buildSearchQuery {
|
||||
my ($self, $sql, $placeHolders, $keywords, $columns) = @_;
|
||||
if ($$sql =~ m/where/) {
|
||||
if ($$sql =~ m/where/i) {
|
||||
$$sql .= ' and (';
|
||||
}
|
||||
else {
|
||||
|
|
@ -384,72 +467,6 @@ sub buildSearchQuery {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 commit ( )
|
||||
|
||||
Ends a transaction sequence. To be used with beginTransaction. Applies all of the writes since beginTransaction to the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub commit {
|
||||
my $self = shift;
|
||||
$self->dbh->commit;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 connect ( session, dsn, user, pass )
|
||||
|
||||
Constructor. Connects to the database using DBI.
|
||||
|
||||
=head2 session
|
||||
|
||||
A reference to the active WebGUI::Session object.
|
||||
|
||||
=head2 dsn
|
||||
|
||||
The Database Service Name of the database you wish to connect to. It looks like 'DBI:mysql:dbname;host=localhost'.
|
||||
|
||||
=head2 user
|
||||
|
||||
The username to use to connect to the database defined by dsn.
|
||||
|
||||
=head2 pass
|
||||
|
||||
The password to use to connect to the database defined by dsn.
|
||||
|
||||
=cut
|
||||
|
||||
sub connect {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $dsn = shift;
|
||||
my $user = shift;
|
||||
my $pass = shift;
|
||||
my $params = shift;
|
||||
|
||||
my (undef, $driver) = DBI->parse_dsn($dsn);
|
||||
my $dbh = DBI->connect($dsn,$user,$pass,{RaiseError => 0, AutoCommit => 1,
|
||||
$driver eq 'mysql' ? (mysql_enable_utf8 => 1) : (),
|
||||
});
|
||||
|
||||
unless (defined $dbh) {
|
||||
$session->errorHandler->error("Couldn't connect to database: $dsn : $DBI::errstr");
|
||||
return undef;
|
||||
}
|
||||
|
||||
##Set specific attributes for this database.
|
||||
my @params = split /\s*\n\s*/, $params;
|
||||
foreach my $param ( @params ) {
|
||||
my ($paramName, $paramValue) = split /\s*=\s*/, $param;
|
||||
$dbh->{$paramName} = $paramValue;
|
||||
}
|
||||
|
||||
bless {_dbh=>$dbh, _session=>$session}, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 dbh ( )
|
||||
|
||||
Returns a reference to the working DBI database handler for this WebGUI::SQL object.
|
||||
|
|
@ -457,8 +474,8 @@ Returns a reference to the working DBI database handler for this WebGUI::SQL obj
|
|||
=cut
|
||||
|
||||
sub dbh {
|
||||
my $self = shift;
|
||||
return $self->{_dbh};
|
||||
my $self = shift;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -483,43 +500,12 @@ The value to search for in the key column.
|
|||
=cut
|
||||
|
||||
sub deleteRow {
|
||||
my ($self, $table, $key, $keyValue) = @_;
|
||||
my $sth = $self->write("delete from ".$self->dbh->quote_identifier($table)." where ".$key."=?", [$keyValue]);
|
||||
my ($self, $table, $key, $keyValue) = @_;
|
||||
$table = $self->quote_identifier($table);
|
||||
$key = $self->quote_identifier($key);
|
||||
return $self->do("DELETE FROM $table WHERE $key = ?", {}, $keyValue);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self->disconnect;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 disconnect ( )
|
||||
|
||||
Disconnects from the database. And destroys the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub disconnect {
|
||||
my $self = shift;
|
||||
my $dbh = delete $self->{_dbh};
|
||||
if ($dbh) {
|
||||
$dbh->disconnect;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 errorCode ( )
|
||||
|
|
@ -529,8 +515,8 @@ Returns an error code for the current handler.
|
|||
=cut
|
||||
|
||||
sub errorCode {
|
||||
my $self = shift;
|
||||
return $self->dbh->err;
|
||||
my $self = shift;
|
||||
return $self->err;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -543,8 +529,8 @@ Returns a text error message for the current handler.
|
|||
=cut
|
||||
|
||||
sub errorMessage {
|
||||
my $self = shift;
|
||||
return $self->dbh->errstr;
|
||||
my $self = shift;
|
||||
return $self->errstr;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -552,7 +538,7 @@ sub errorMessage {
|
|||
|
||||
=head2 getNextId ( idName )
|
||||
|
||||
Increments an incrementer of the specified type and returns the value.
|
||||
Increments an incrementer of the specified type and returns the value.
|
||||
|
||||
=head3 idName
|
||||
|
||||
|
|
@ -561,14 +547,13 @@ Specify the name of one of the incrementers in the incrementer table.
|
|||
=cut
|
||||
|
||||
sub getNextId {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my ($id);
|
||||
$self->beginTransaction;
|
||||
($id) = $self->quickArray("select nextValue from incrementer where incrementerId=?", [$name]);
|
||||
$self->write("update incrementer set nextValue=nextValue+1 where incrementerId=?",[$name]);
|
||||
$self->commit;
|
||||
return $id;
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
$self->begin_work;
|
||||
my $id = $self->selectrow_array('SELECT nextValue FROM incrementer WHERE incrementerId = ?', {}, $name);
|
||||
$self->do('UPDATE incrementer SET nextValue=nextValue+1 WHERE incrementerId=?', {}, $name);
|
||||
$self->commit;
|
||||
return $id;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -581,7 +566,7 @@ Returns the DBI driver used by this database link
|
|||
|
||||
sub getDriver {
|
||||
my $self = shift;
|
||||
return $self->{_dbh}->{Driver}->{Name};
|
||||
return $self->{Driver}->{Name};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -605,30 +590,18 @@ The value to search for in the key column.
|
|||
=cut
|
||||
|
||||
sub getRow {
|
||||
my ($self, $table, $key, $keyValue) = @_;
|
||||
my $row = $self->quickHashRef("select * from ".$self->dbh->quote_identifier($table)." where ".$key."=?",[$keyValue]);
|
||||
return $row;
|
||||
my ($self, $table, $key, $keyValue) = @_;
|
||||
my $row = $self->selectrow_hashref(
|
||||
sprintf('SELECT * FROM %s WHERE %s = ?',
|
||||
$self->quote_identifier($table),
|
||||
$self->quote_identifier($key)
|
||||
),
|
||||
{},
|
||||
$keyValue,
|
||||
);
|
||||
return $row;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 prepare ( sql )
|
||||
|
||||
This is a wrapper for WebGUI::SQL::ResultSet->prepare()
|
||||
|
||||
=head3 sql
|
||||
|
||||
An SQL statement.
|
||||
|
||||
=cut
|
||||
|
||||
sub prepare {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
return WebGUI::SQL::ResultSet->prepare($sql, $self);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 quickArray ( sql, params )
|
||||
|
|
@ -646,11 +619,10 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub quickArray {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift || [];
|
||||
my $data = $self->dbh->selectrow_arrayref($sql, {}, @{ $params }) || [];
|
||||
return @{ $data };
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift || [];
|
||||
return $self->selectrow_array($sql, {}, @{ $params });
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -671,26 +643,25 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub quickCSV {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my ($sth, $output, @data);
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
|
||||
my $csv = Text::CSV_XS->new({ eol => "\n" });
|
||||
my $csv = Text::CSV_XS->new({ eol => "\n" });
|
||||
|
||||
$sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute(@$params);
|
||||
|
||||
return undef unless $csv->combine($sth->getColumnNames);
|
||||
$output = $csv->string();
|
||||
return undef unless $csv->combine($sth->getColumnNames);
|
||||
my $output = $csv->string;
|
||||
|
||||
while (@data = $sth->array) {
|
||||
return undef unless $csv->combine(@data);
|
||||
$output .= $csv->string();
|
||||
}
|
||||
while (my @data = $sth->fetchrow_array) {
|
||||
return undef unless $csv->combine(@data);
|
||||
$output .= $csv->string;
|
||||
}
|
||||
|
||||
$sth->finish;
|
||||
return $output;
|
||||
$sth->finish;
|
||||
return $output;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -711,19 +682,11 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub quickHash {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my ($sth, $data);
|
||||
$sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
$data = $sth->hashRef;
|
||||
$sth->finish;
|
||||
if (defined $data) {
|
||||
return %{$data};
|
||||
} else {
|
||||
return ();
|
||||
}
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $row = $self->selectrow_hashref($sql, {}, @$params);
|
||||
return %{$row};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -743,18 +706,10 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub quickHashRef {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
my $data = $sth->hashRef;
|
||||
$sth->finish;
|
||||
if (defined $data) {
|
||||
return $data;
|
||||
} else {
|
||||
return {};
|
||||
}
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
return $self->selectrow_hashref($sql, {}, @$params);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -774,15 +729,11 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub quickScalar {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my ($sth, @data);
|
||||
$sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
@data = $sth->array;
|
||||
$sth->finish;
|
||||
return $data[0];
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my ($data) = $self->selectrow_array($sql, {}, @$params);
|
||||
return $data;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -803,39 +754,18 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub quickTab {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my ($sth, $output, @data);
|
||||
$sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
$output = join("\t",$sth->getColumnNames)."\n";
|
||||
while (@data = $sth->array) {
|
||||
makeArrayTabSafe(\@data);
|
||||
$output .= join("\t",@data)."\n";
|
||||
}
|
||||
$sth->finish;
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 quote ( string )
|
||||
|
||||
Returns a string quoted and ready for insert into the database.
|
||||
|
||||
B<NOTE:> You should use this sparingly. It is much faster and safer to use prepare/execute style queries and passing in place holder parameters. Even the convenience methods like quickArray() support the use of place holder parameters.
|
||||
|
||||
=head3 string
|
||||
|
||||
Any scalar variable that needs to be escaped to be inserted into the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub quote {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return $self->dbh->quote($value);
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute(@{$params});
|
||||
my $output = join("\t", $sth->getColumnNames) . "\n";
|
||||
while (my @data = $sth->fetchrow_array) {
|
||||
WebGUI::Utility::makeArrayTabSafe(\@data);
|
||||
$output .= join("\t", @data) . "\n";
|
||||
}
|
||||
$sth->finish;
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -851,13 +781,9 @@ An array reference containing strings to be quoted.
|
|||
=cut
|
||||
|
||||
sub quoteAndJoin {
|
||||
my $self = shift;
|
||||
my $arrayRef = shift;
|
||||
my @newArray;
|
||||
foreach my $value (@$arrayRef) {
|
||||
push(@newArray,$self->quote($value));
|
||||
}
|
||||
return join(",",@newArray);
|
||||
my $self = shift;
|
||||
my $arrayRef = shift;
|
||||
return join ',', map { $self->quote($_) } @$arrayRef;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -875,8 +801,7 @@ Any scalar variable that needs to be escaped to be inserted into the database.
|
|||
|
||||
sub quoteIdentifier {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return $self->dbh->quote_identifier($value);
|
||||
return $self->quote_identifier(@_);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -897,31 +822,14 @@ An array reference containing a list of values to be used in the placeholders de
|
|||
=cut
|
||||
|
||||
sub read {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $placeholders = shift;
|
||||
return WebGUI::SQL::ResultSet->read($sql, $self, $placeholders);
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $placeholders = shift;
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute(@$placeholders);
|
||||
return $sth;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 rollback ( )
|
||||
|
||||
Ends a transaction sequence. To be used with beginTransaction. Cancels all of the writes since beginTransaction.
|
||||
|
||||
=head3 dbh
|
||||
|
||||
A database handler. Defaults to the WebGUI default database handler.
|
||||
|
||||
=cut
|
||||
|
||||
sub rollback {
|
||||
my $self = shift;
|
||||
$self->dbh->rollback;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
|
@ -931,8 +839,12 @@ Returns a reference to the current session.
|
|||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
return $self->{_session};
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{private_webgui_session} = shift;
|
||||
Scalar::Util::weaken $self->{private_webgui_session};
|
||||
}
|
||||
return $self->{private_webgui_session};
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -961,26 +873,32 @@ Use this ID to create a new row. Same as setting the key value to "new" except t
|
|||
=cut
|
||||
|
||||
sub setRow {
|
||||
my ($self, $table, $keyColumn, $data, $id) = @_;
|
||||
if ($data->{$keyColumn} eq "new" || $id) {
|
||||
$data->{$keyColumn} = $id || $self->session->id->generate();
|
||||
$self->write("replace into ".$self->dbh->quote_identifier($table)
|
||||
." (" . $self->dbh->quote_identifier($keyColumn) . ") values (?)",[$data->{$keyColumn}]);
|
||||
}
|
||||
my @fields = ();
|
||||
my @data = ();
|
||||
foreach my $key (keys %{$data}) {
|
||||
unless ($key eq $keyColumn) {
|
||||
push(@fields, $self->dbh->quote_identifier($key).'=?');
|
||||
push(@data,$data->{$key});
|
||||
}
|
||||
}
|
||||
if ($fields[0] ne "") {
|
||||
push(@data,$data->{$keyColumn});
|
||||
$self->write("update ".$self->dbh->quote_identifier($table)." set " . join(", ", @fields)
|
||||
. " where " . $self->dbh->quote_identifier($keyColumn) . "=?", \@data);
|
||||
}
|
||||
return $data->{$keyColumn};
|
||||
my ($self, $table, $keyColumn, $data, $id) = @_;
|
||||
$table = $self->quote_identifier($table);
|
||||
my $key = $self->quote_identifier($keyColumn);
|
||||
|
||||
if ($data->{$keyColumn} eq 'new' || $id) {
|
||||
$id ||= $self->session->id->generate;
|
||||
$data->{$keyColumn} = $id;
|
||||
}
|
||||
else {
|
||||
$id = $data->{$keyColumn};
|
||||
}
|
||||
|
||||
try {
|
||||
my $fields = join ', ', map { $self->quote_identifier($_) } keys %$data;
|
||||
my $values = join ', ', ('?') x values %$data;
|
||||
$self->do("INSERT INTO $table ($fields) VALUES ($values)", {}, values %$data);
|
||||
}
|
||||
catch {
|
||||
my %data = %$data;
|
||||
delete $data{$keyColumn};
|
||||
|
||||
my $fields = join ', ', map { $self->quote_identifier($_). '=?' } keys %data;
|
||||
$self->do("UPDATE $table SET $fields WHERE $key = ?", {}, values %data, $id);
|
||||
};
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -1000,10 +918,11 @@ An array reference containing a list of values to be used in the placeholders de
|
|||
=cut
|
||||
|
||||
sub unconditionalRead {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $placeholders = shift;
|
||||
return WebGUI::SQL::ResultSet->unconditionalRead($sql, $self, $placeholders);
|
||||
my $self = shift;
|
||||
local $self->{RaiseError} = 0;
|
||||
local $self->{HandleError} = undef;
|
||||
my $sth = $self->read(@_);
|
||||
return $sth;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1025,11 +944,10 @@ An array reference containing values for any placeholder params used in the SQL
|
|||
=cut
|
||||
|
||||
sub write {
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
my $sth = $self->prepare($sql);
|
||||
$sth->execute($params);
|
||||
my $self = shift;
|
||||
my $sql = shift;
|
||||
my $params = shift;
|
||||
return $self->do($sql, {}, @$params);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -26,8 +26,6 @@ This class provides methods for working with SQL result sets. If you're used to
|
|||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::SQL::ResultSet;
|
||||
|
||||
my $result = WebGUI::SQL::ResultSet->prepare($query, $db);
|
||||
|
||||
$result->execute([ @values ]);
|
||||
|
|
@ -44,162 +42,6 @@ This class provides methods for working with SQL result sets. If you're used to
|
|||
These methods are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 array ( )
|
||||
|
||||
Returns the next row of data as an array.
|
||||
|
||||
=cut
|
||||
|
||||
sub array {
|
||||
my $self = shift;
|
||||
return $self->sth->fetchrow_array() or $self->db->session->errorHandler->fatal("Couldn't fetch array. ".$self->errorMessage);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 arrayRef ( )
|
||||
|
||||
Returns the next row of data as an array reference. Note that this is 12% faster than array().
|
||||
|
||||
=cut
|
||||
|
||||
sub arrayRef {
|
||||
my $self = shift;
|
||||
return $self->sth->fetchrow_arrayref() or $self->db->session->errorHandler->fatal("Couldn't fetch array. ".$self->errorMessage);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 db ( )
|
||||
|
||||
A reference to the current WebGUI::SQL object.
|
||||
|
||||
=cut
|
||||
|
||||
sub db {
|
||||
my $self = shift;
|
||||
return $self->{_db};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 errorCode {
|
||||
|
||||
Returns an error code for the current handler.
|
||||
|
||||
=cut
|
||||
|
||||
sub errorCode {
|
||||
my $self = shift;
|
||||
return $self->sth->err;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 errorMessage {
|
||||
|
||||
Returns a text error message for the current handler.
|
||||
|
||||
=cut
|
||||
|
||||
sub errorMessage {
|
||||
my $self = shift;
|
||||
return $self->sth->errstr;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 execute ( [ placeholders ] )
|
||||
|
||||
Executes a prepared SQL statement. For SELECT queries, returns a true value on success. For
|
||||
other queries, returns the number of rows effected. Return value will always evaluate as true
|
||||
even if zero rows were effected.
|
||||
|
||||
=head3 placeholders
|
||||
|
||||
An array reference containing a list of values to be used in the placeholders defined in the SQL statement.
|
||||
|
||||
=cut
|
||||
|
||||
sub execute {
|
||||
my $self = shift;
|
||||
my $placeholders = shift || [];
|
||||
my $sql = $self->{_sql};
|
||||
my $errorHandler = $self->db->session->errorHandler;
|
||||
$errorHandler->query($sql,$placeholders);
|
||||
$self->sth->execute(@{ $placeholders }) or $errorHandler->fatal("Couldn't execute prepared statement: $sql : With place holders: ".join(", ", @{$placeholders}).". Root cause: ". $self->errorMessage);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 finish ( )
|
||||
|
||||
Releases the result set. Should be called to complete any statement handler.
|
||||
|
||||
=cut
|
||||
|
||||
sub finish {
|
||||
my $self = shift;
|
||||
return $self->sth->finish;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getColumnNames
|
||||
|
||||
Returns an array of column names. Use with a "read" method.
|
||||
|
||||
=cut
|
||||
|
||||
sub getColumnNames {
|
||||
my $self = shift;
|
||||
return @{$self->sth->{NAME}} if (ref $self->sth->{NAME} eq 'ARRAY');
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 hash ( )
|
||||
|
||||
Returns the next row of data in the form of a hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
my ($hashRef);
|
||||
$hashRef = $self->sth->fetchrow_hashref();
|
||||
if (defined $hashRef) {
|
||||
return %{$hashRef};
|
||||
} else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 hashRef ( )
|
||||
|
||||
Returns the next row of data in the form of a hash reference.
|
||||
|
||||
=cut
|
||||
|
||||
sub hashRef {
|
||||
my $self = shift;
|
||||
return $self->sth->fetchrow_hashref();
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 prepare ( sql, db )
|
||||
|
|
@ -217,14 +59,12 @@ A WebGUI::SQL database handler.
|
|||
=cut
|
||||
|
||||
sub prepare {
|
||||
my $class = shift;
|
||||
my $sql = shift;
|
||||
my $db = shift;
|
||||
my $sth = $db->dbh->prepare($sql) or $db->session->errorHandler->fatal("Couldn't prepare statement: ".$sql." : ". $db->dbh->errstr);
|
||||
bless {_sth => $sth, _sql => $sql, _db=>$db}, $class;
|
||||
my $class = shift;
|
||||
my $sql = shift;
|
||||
my $db = shift;
|
||||
return $db->prepare($sql);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 read ( sql, db, placeholders )
|
||||
|
|
@ -247,43 +87,13 @@ An array reference containing a list of values to be used in the placeholders de
|
|||
=cut
|
||||
|
||||
sub read {
|
||||
my $class = shift;
|
||||
my $sql = shift;
|
||||
my $db = shift;
|
||||
my $placeholders = shift;
|
||||
my $self = $db->prepare($sql, $db);
|
||||
$self->execute($placeholders);
|
||||
return $self;
|
||||
my $class = shift;
|
||||
my $sql = shift;
|
||||
my $db = shift;
|
||||
my $placeholders = shift;
|
||||
return $db->read($sql, $placeholders);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 rows ( )
|
||||
|
||||
Returns the number of rows in the result set.
|
||||
|
||||
=cut
|
||||
|
||||
sub rows {
|
||||
my $self = shift;
|
||||
return $self->sth->rows;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 sth ( )
|
||||
|
||||
Returns the working DBI statement handler for this result set.
|
||||
|
||||
=cut
|
||||
|
||||
sub sth {
|
||||
my $self = shift;
|
||||
return $self->{_sth};
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 unconditionalRead ( sql, db, placeholders )
|
||||
|
|
@ -305,19 +115,161 @@ An array reference containing a list of values to be used in the placeholders de
|
|||
=cut
|
||||
|
||||
sub unconditionalRead {
|
||||
my $class = shift;
|
||||
my $sql = shift;
|
||||
my $db = shift;
|
||||
my $placeholders = shift;
|
||||
my $errorHandler = $db->session->errorHandler;
|
||||
$errorHandler->query($sql,$placeholders);
|
||||
my $sth = $db->dbh->prepare($sql) or $errorHandler->warn("Unconditional read failed: ".$sql." : ".$db->dbh->errstr);
|
||||
if ($sth) {
|
||||
$sth->execute(@$placeholders) or $errorHandler->warn("Unconditional read failed: ".$sql." : ".$sth->errstr);
|
||||
bless {_sql=>$sql, _db=>$db, _sth=>$sth}, $class;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
my $class = shift;
|
||||
my $sql = shift;
|
||||
my $db = shift;
|
||||
my $placeholders = shift;
|
||||
return $db->unconditionalRead($sql, $placeholders);
|
||||
}
|
||||
|
||||
package WebGUI::SQL::st;
|
||||
|
||||
our @ISA = qw(DBI::st);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 array ( )
|
||||
|
||||
Returns the next row of data as an array.
|
||||
|
||||
=cut
|
||||
|
||||
sub array {
|
||||
my $self = shift;
|
||||
return $self->fetchrow_array;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 arrayRef ( )
|
||||
|
||||
Returns the next row of data as an array reference. Note that this is 12% faster than array().
|
||||
|
||||
=cut
|
||||
|
||||
sub arrayRef {
|
||||
my $self = shift;
|
||||
return $self->fetchrow_arrayref;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 db ( )
|
||||
|
||||
A reference to the current WebGUI::SQL object.
|
||||
|
||||
=cut
|
||||
|
||||
sub db {
|
||||
my $self = shift;
|
||||
return $self->{Database};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 errorCode {
|
||||
|
||||
Returns an error code for the current handler.
|
||||
|
||||
=cut
|
||||
|
||||
sub errorCode {
|
||||
my $self = shift;
|
||||
return $self->err;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 errorMessage {
|
||||
|
||||
Returns a text error message for the current handler.
|
||||
|
||||
=cut
|
||||
|
||||
sub errorMessage {
|
||||
my $self = shift;
|
||||
return $self->errstr;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 execute ( [ placeholders ] )
|
||||
|
||||
Executes a prepared SQL statement. For SELECT queries, returns a true value on success. For
|
||||
other queries, returns the number of rows effected. Return value will always evaluate as true
|
||||
even if zero rows were effected.
|
||||
|
||||
=head3 placeholders
|
||||
|
||||
An array reference containing a list of values to be used in the placeholders defined in the SQL statement.
|
||||
|
||||
=cut
|
||||
|
||||
sub execute {
|
||||
my $self = shift;
|
||||
my $placeholders =
|
||||
( @_ == 1 && ref $_[0] eq 'ARRAY' ) ? $_[0]
|
||||
: \@_;
|
||||
return $self->SUPER::execute(@$placeholders);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getColumnNames
|
||||
|
||||
Returns an array of column names. Use with a "read" method.
|
||||
|
||||
=cut
|
||||
|
||||
sub getColumnNames {
|
||||
my $self = shift;
|
||||
return @{ $self->{NAME} }
|
||||
if (ref $self->{NAME} eq 'ARRAY');
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 hash ( )
|
||||
|
||||
Returns the next row of data in the form of a hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub hash {
|
||||
my $self = shift;
|
||||
my $hashRef = $self->fetchrow_hashref || {};
|
||||
return %$hashRef;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 hashRef ( )
|
||||
|
||||
Returns the next row of data in the form of a hash reference.
|
||||
|
||||
=cut
|
||||
|
||||
sub hashRef {
|
||||
my $self = shift;
|
||||
return $self->fetchrow_hashref;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 sth ( )
|
||||
|
||||
Returns the working DBI statement handler for this result set.
|
||||
|
||||
=cut
|
||||
|
||||
sub sth {
|
||||
my $self = shift;
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -151,19 +151,6 @@ sub delete {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 _filterKeywords ( $keywords )
|
||||
|
||||
Perform filtering and cleaning up of the keywords before submitting them. Ideographic characters are padded
|
||||
|
|
|
|||
|
|
@ -29,9 +29,9 @@ use WebGUI::Session::Form;
|
|||
use WebGUI::Session::Http;
|
||||
use WebGUI::Session::Icon;
|
||||
use WebGUI::Session::Id;
|
||||
use WebGUI::Session::Os;
|
||||
use WebGUI::Session::Output;
|
||||
use WebGUI::Session::Privilege;
|
||||
use WebGUI::Session::Request;
|
||||
use WebGUI::Session::Scratch;
|
||||
use WebGUI::Session::Setting;
|
||||
use WebGUI::Session::Stow;
|
||||
|
|
@ -70,11 +70,10 @@ B<NOTE:> It is important to distinguish the difference between a WebGUI session
|
|||
$session->icon
|
||||
$session->id
|
||||
$session->output
|
||||
$session->os
|
||||
$session->privilege
|
||||
$session->request
|
||||
$session->response
|
||||
$session->scratch
|
||||
$session->server
|
||||
$session->setting
|
||||
$session->stow
|
||||
$session->style
|
||||
|
|
@ -169,7 +168,7 @@ sub close {
|
|||
|
||||
# Kill circular references. The literal list is so that the order
|
||||
# can be explicitly shuffled as necessary.
|
||||
foreach my $key (qw/_asset _datetime _icon _slave _db _env _form _http _id _output _os _privilege _scratch _setting _stow _style _url _user _var _cache _errorHandler/) {
|
||||
foreach my $key (qw/_asset _datetime _icon _slave _db _env _form _http _id _output _privilege _scratch _setting _stow _style _url _user _var _cache _errorHandler _response _request/) {
|
||||
delete $self->{$key};
|
||||
}
|
||||
}
|
||||
|
|
@ -318,7 +317,7 @@ Returns a WebGUI::Session::Env object.
|
|||
sub env {
|
||||
my $self = shift;
|
||||
unless (exists $self->{_env}) {
|
||||
$self->{_env} = WebGUI::Session::Env->new;
|
||||
$self->{_env} = WebGUI::Session::Env->new($self);
|
||||
}
|
||||
return $self->{_env};
|
||||
}
|
||||
|
|
@ -448,7 +447,7 @@ sub log {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 open ( webguiRoot, configFile [, requestObject, serverObject, sessionId, noFuss ] )
|
||||
=head2 open ( webguiRoot, configFile [, env, sessionId, noFuss ] )
|
||||
|
||||
Constructor. Opens a closed ( or new ) WebGUI session.
|
||||
|
||||
|
|
@ -458,19 +457,16 @@ The path to the WebGUI files.
|
|||
|
||||
=head3 configFile
|
||||
|
||||
The filename of the config file that WebGUI should operate from.
|
||||
The filename of the config file that WebGUI should operate from, or a WebGUI::Config object
|
||||
|
||||
=head3 requestObject
|
||||
=head3 env
|
||||
|
||||
The Apache request object (aka $r). If this session is being instanciated from the web, this is required.
|
||||
|
||||
=head3 serverObject
|
||||
|
||||
The Apache server object (Apache2::ServerUtil). If this session is being instanciated from the web, this is required.
|
||||
The L<PSGI> env hash. If this session is being instanciated from the web, this is required.
|
||||
|
||||
=head3 sessionId
|
||||
|
||||
Optionally retrieve a specific session id. Normally this is set by a cookie in the user's browser.
|
||||
If you have a L<PSGI> env hash, you might find the sessionId at: $env->{'psgix.session'}->id
|
||||
|
||||
=head3 noFuss
|
||||
|
||||
|
|
@ -479,23 +475,26 @@ Uses simple session vars. See WebGUI::Session::Var::new() for more details.
|
|||
=cut
|
||||
|
||||
sub open {
|
||||
my $class = shift;
|
||||
my $configFile = shift;
|
||||
my $request = shift;
|
||||
my $server = shift;
|
||||
my $config;
|
||||
if (eval { $configFile->isa('WebGUI::Config') } ) {
|
||||
$config = $configFile;
|
||||
my ($class, $c, $env, $sessionId, $noFuss) = @_;
|
||||
my $config = ref $c ? $c : WebGUI::Config->new($c);
|
||||
my $self = { _config => $config };
|
||||
bless $self, $class;
|
||||
|
||||
if ($env) {
|
||||
my $request = WebGUI::Session::Request->new($env);
|
||||
$self->{_request} = $request;
|
||||
$self->{_response} = $request->new_response( 200 );
|
||||
|
||||
# Use the WebGUI::Session::Request object to look up the sessionId from cookies, if it
|
||||
# wasn't given explicitly
|
||||
$sessionId ||= $request->cookies->{$config->getCookieName};
|
||||
}
|
||||
else {
|
||||
$config = WebGUI::Config->new($configFile);
|
||||
|
||||
# If the sessionId is still unset or is invalid, generate a new one
|
||||
if (!$sessionId || !$self->id->valid($sessionId)) {
|
||||
$sessionId = $self->id->generate;
|
||||
}
|
||||
my $self = {_config=>$config, _server=>$server};
|
||||
bless $self , $class;
|
||||
$self->{_request} = $request if (defined $request);
|
||||
my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate;
|
||||
$sessionId = $self->id->generate unless $self->id->valid($sessionId);
|
||||
my $noFuss = shift;
|
||||
|
||||
$self->{_var} = WebGUI::Session::Var->new($self,$sessionId, $noFuss);
|
||||
return $self;
|
||||
}
|
||||
|
|
@ -517,23 +516,6 @@ sub output {
|
|||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 os ( )
|
||||
|
||||
Returns a WebGUI::Session::Os object.
|
||||
|
||||
=cut
|
||||
|
||||
sub os {
|
||||
my $self = shift;
|
||||
unless (exists $self->{_os}) {
|
||||
$self->{_os} = WebGUI::Session::Os->new();
|
||||
}
|
||||
return $self->{_os};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 privilege ( )
|
||||
|
|
@ -576,7 +558,7 @@ sub quick {
|
|||
|
||||
=head2 request ( )
|
||||
|
||||
Returns the Apache request (aka $r) object, or undef if it doesn't exist.
|
||||
Returns the L<Plack::Request> object, or undef if it doesn't exist.
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -587,6 +569,19 @@ sub request {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 response ( )
|
||||
|
||||
Returns the L<Plack::Response> object, or undef if it doesn't exist.
|
||||
|
||||
=cut
|
||||
|
||||
sub response {
|
||||
my $self = shift;
|
||||
return $self->{_response};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 scratch ( )
|
||||
|
||||
Returns a WebGUI::Session::Scratch object.
|
||||
|
|
@ -605,13 +600,13 @@ sub scratch {
|
|||
|
||||
=head2 server ( )
|
||||
|
||||
Returns the Apache server object (Apache2::ServerUtil), or undef if it doesn't exist.
|
||||
DEPRECATED (used to return the Apache2::ServerUtil object)
|
||||
|
||||
=cut
|
||||
|
||||
sub server {
|
||||
my $self = shift;
|
||||
return $self->{_server};
|
||||
$self->log->fatal('WebGUI::Session::server is deprecated');
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -21,7 +21,8 @@ use DateTime::Format::Mail;
|
|||
use DateTime::TimeZone;
|
||||
use Tie::IxHash;
|
||||
use WebGUI::International;
|
||||
use WebGUI::Utility;
|
||||
use WebGUI::Utility qw(round isIn);
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
|
@ -226,19 +227,6 @@ sub dayStartEnd {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 epochToHttp ( [ epoch ] )
|
||||
|
||||
Converts and epoch date into an HTTP formatted date.
|
||||
|
|
@ -808,7 +796,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -99,21 +99,6 @@ sub clientIsSpider {
|
|||
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( varName )
|
||||
|
|
@ -127,9 +112,9 @@ The name of the variable.
|
|||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
return $self->{_env}{$var};
|
||||
my $self = shift;
|
||||
my $var = shift;
|
||||
return $$self->{$var};
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -137,16 +122,13 @@ sub get {
|
|||
|
||||
=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.
|
||||
Returns the user's IP address.
|
||||
|
||||
=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");
|
||||
my $self = shift;
|
||||
return $self->get('REMOTE_ADDR');
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -159,8 +141,16 @@ Constructor. Returns an env object.
|
|||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
bless {_env=>\%ENV}, $class;
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $env;
|
||||
if ($session->request) {
|
||||
$env = $session->request->env;
|
||||
}
|
||||
else {
|
||||
$env = {};
|
||||
}
|
||||
return bless \$env, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -195,12 +185,7 @@ was made via SSL.
|
|||
|
||||
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'
|
||||
);
|
||||
return $self->get('psgi.url_scheme') eq 'https';
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -16,13 +16,12 @@ package WebGUI::Session::ErrorHandler;
|
|||
|
||||
|
||||
use strict;
|
||||
use Log::Log4perl;
|
||||
use WebGUI::Paths;
|
||||
#use Apache2::RequestUtil;
|
||||
use JSON;
|
||||
use HTML::Entities qw(encode_entities);
|
||||
use WebGUI::Exception;
|
||||
use Sub::Uplevel;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Session::ErrorHandler
|
||||
|
||||
|
|
@ -70,67 +69,10 @@ 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";
|
||||
my $message = shift;
|
||||
@_ = ($self, $self->session->user->username." (".$self->session->user->userId.") ".$message);
|
||||
goto $self->can('info');
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -141,10 +83,13 @@ Returns true if the user meets the conditions to see performance indicators and
|
|||
|
||||
=cut
|
||||
|
||||
sub canShowPerformanceIndicators {
|
||||
my $self = shift;
|
||||
return 0 unless $self->session->setting->get("showPerformanceIndicators");
|
||||
return $self->canShowBasedOnIP('debugIp');
|
||||
sub performanceLogger {
|
||||
my $self = shift;
|
||||
my $request = $self->session->request;
|
||||
return
|
||||
unless $request;
|
||||
my $logger = $request->env->{'webgui.perf.logger'};
|
||||
return $logger;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -161,29 +106,12 @@ The message you wish to add to the log.
|
|||
=cut
|
||||
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->debug($message);
|
||||
$self->{_debug_debug} .= $message."\n";
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
@_ = ({ level => 'debug', message => $message });
|
||||
goto $self->getLogger;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 error ( message )
|
||||
|
|
@ -197,12 +125,10 @@ The message you wish to add to the log.
|
|||
=cut
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
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";
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
@_ = ({ level => 'error', message => $message});
|
||||
goto $self->getLogger;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -219,39 +145,10 @@ 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;
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
Sub::Uplevel::uplevel( 1, $self->getLogger, { level => 'fatal', message => $message});
|
||||
WebGUI::Error::Fatal->throw( error => $message );
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -264,32 +161,9 @@ Returns a reference to the logger.
|
|||
=cut
|
||||
|
||||
sub getLogger {
|
||||
my $self = shift;
|
||||
return $self->{_logger};
|
||||
$_[0]->{_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 )
|
||||
|
|
@ -303,11 +177,10 @@ The message you wish to add to the log.
|
|||
=cut
|
||||
|
||||
sub info {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->info($message);
|
||||
$self->{_debug_info} .= $message."\n";
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
@_ = ({ level => 'info', message => $message});
|
||||
goto $self->getLogger;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -323,11 +196,29 @@ An active WebGUI::Session object.
|
|||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
Log::Log4perl->init_once( WebGUI::Paths->logConfig );
|
||||
my $logger = Log::Log4perl->get_logger($session->config->getFilename);
|
||||
bless {_queryCount=>0, _logger=>$logger, _session=>$session}, $class;
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
my $logger = $session->request && $session->request->logger;
|
||||
if ( !$logger ) {
|
||||
|
||||
# Thanks to Plack, wG has been decoupled from Log4Perl
|
||||
# However when called outside a web context, we currently still fall back to Log4perl
|
||||
# (pending a better idea)
|
||||
require Log::Log4perl;
|
||||
Log::Log4perl->init_once( WebGUI::Paths->logConfig );
|
||||
my $log4perl = Log::Log4perl->get_logger( $session->config->getFilename );
|
||||
$logger = sub {
|
||||
my $args = shift;
|
||||
my $level = $args->{level};
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$log4perl->$level( $args->{message} );
|
||||
};
|
||||
}
|
||||
$self->{_logger} = $logger;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -346,47 +237,6 @@ sub preventDebugOutput {
|
|||
$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 )
|
||||
|
|
@ -400,10 +250,11 @@ 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);
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
@_ = ($self, $self->session->user->username." (".$self->session->user->userId.") connecting from "
|
||||
.$self->session->env->getIp." attempted to ".$message);
|
||||
goto $self->can('warn');
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -420,43 +271,6 @@ sub session {
|
|||
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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
|
|
@ -471,13 +285,11 @@ The message you wish to add to the log.
|
|||
=cut
|
||||
|
||||
sub warn {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
|
||||
$self->getLogger->warn($message);
|
||||
$self->{_debug_warn} .= $message."\n";
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
@_ = ({ level => 'warn', message => $message});
|
||||
goto $self->getLogger;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ package WebGUI::Session::Form;
|
|||
=cut
|
||||
|
||||
use strict qw(vars subs);
|
||||
use WebGUI::HTML;
|
||||
use Encode ();
|
||||
use Tie::IxHash;
|
||||
use base 'WebGUI::FormValidator';
|
||||
|
|
@ -64,6 +63,7 @@ sub AUTOLOAD {
|
|||
my @args = @_;
|
||||
our $AUTOLOAD;
|
||||
my $method = "SUPER::".(split /::/, $AUTOLOAD)[-1];
|
||||
return if $method eq 'SUPER::DESTROY';
|
||||
return $self->$method(@args);
|
||||
}
|
||||
|
||||
|
|
@ -78,10 +78,7 @@ Returns true if the param is part of the submitted form data, or a URL param.
|
|||
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};
|
||||
return $param && $self->session->request && exists $self->session->request->parameters->{$param};
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,15 @@ package WebGUI::Session::Http;
|
|||
|
||||
|
||||
use strict;
|
||||
use WebGUI::Utility;
|
||||
use Scalar::Util qw(weaken);
|
||||
use WebGUI::Utility qw(isIn);
|
||||
use HTTP::Date ();
|
||||
|
||||
sub _deprecated {
|
||||
my $alt = shift;
|
||||
my $method = (caller(1))[3];
|
||||
Carp::carp("$method is deprecated. Use 'WebGUI::$alt' instead.");
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -53,21 +61,6 @@ These methods are available from this package:
|
|||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getCacheControl ( )
|
||||
|
|
@ -91,16 +84,8 @@ Retrieves the cookies from the HTTP header and returns a hash reference containi
|
|||
|
||||
sub getCookies {
|
||||
my $self = shift;
|
||||
if ($self->session->request) {
|
||||
# Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows)
|
||||
require APR::Request::Apache2;
|
||||
my $jarHashRef = APR::Request::Apache2->handle($self->session->request)->jar();
|
||||
return $jarHashRef if $jarHashRef;
|
||||
return {};
|
||||
}
|
||||
else {
|
||||
return {};
|
||||
}
|
||||
_deprecated('Request::cookies');
|
||||
return $self->session->request->cookies;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -224,10 +209,9 @@ sub ifModifiedSince {
|
|||
my $self = shift;
|
||||
my $epoch = shift;
|
||||
my $maxCacheTimeout = shift;
|
||||
require APR::Date;
|
||||
my $modified = $self->session->request->headers_in->{'If-Modified-Since'};
|
||||
my $modified = $self->session->request->header('If-Modified-Since');
|
||||
return 1 if ($modified eq "");
|
||||
$modified = APR::Date::parse_http($modified);
|
||||
$modified = HTTP::Date::str2time($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.
|
||||
|
|
@ -248,7 +232,8 @@ Returns a boolean value indicating whether the current page will redirect to som
|
|||
|
||||
sub isRedirect {
|
||||
my $self = shift;
|
||||
return isIn($self->getStatus(), qw(302 301));
|
||||
my $status = $self->getStatus;
|
||||
return $status == 302 || $status == 301;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -267,7 +252,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -284,61 +271,60 @@ sub sendHeader {
|
|||
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));
|
||||
my ($request, $response, $config, $var) = $self->session->quick(qw(request response 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->setCookie($cookieName,$var->getId, $config->getCookieTTL, $config->get("cookieDomain")) unless $var->getId eq $request->cookies->{$cookieName};
|
||||
|
||||
$self->setNoHeader(1);
|
||||
my %params;
|
||||
if ($self->isRedirect()) {
|
||||
$request->headers_out->set(Location => $self->getRedirectLocation);
|
||||
$request->status($self->getStatus);
|
||||
$response->header(Location => $self->getRedirectLocation);
|
||||
$response->status($self->getStatus);
|
||||
} else {
|
||||
$request->content_type($self->getMimeType);
|
||||
$response->content_type($self->getMimeType);
|
||||
my $cacheControl = $self->getCacheControl;
|
||||
my $date = ($userId eq "1") ? $datetime->epochToHttp($self->getLastModified) : $datetime->epochToHttp;
|
||||
my $date = ($userId eq "1") ? HTTP::Date::time2str($self->getLastModified) : HTTP::Date::time2str();
|
||||
# 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);
|
||||
$response->header("Cache-Control" => "private, max-age=1");
|
||||
# $response->no_cache(1); # TODO - re-enable this?
|
||||
}
|
||||
# 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);
|
||||
$response->header("Cache-Control" => "private, max-age=1");
|
||||
}
|
||||
else {
|
||||
$request->headers_out->set('Last-Modified' => $date);
|
||||
$request->headers_out->set('Cache-Control' => "must-revalidate, max-age=" . $cacheControl);
|
||||
$response->header('Last-Modified' => $date);
|
||||
$response->header('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);
|
||||
my $date = HTTP::Date::time2str(time() + $cacheControl);
|
||||
$response->header( 'Expires' => $date );
|
||||
}
|
||||
}
|
||||
if ($self->getFilename) {
|
||||
$request->headers_out->set('Content-Disposition' => qq{attachment; filename="}.$self->getFilename().'"');
|
||||
$response->headers( 'Content-Disposition' => qq{attachment; filename="}.$self->getFilename().'"');
|
||||
}
|
||||
$request->status($self->getStatus());
|
||||
$request->status_line($self->getStatus().' '.$self->getStatusDescription());
|
||||
$response->status($self->getStatus());
|
||||
# $response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable
|
||||
}
|
||||
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());
|
||||
my $response = $self->session->response;
|
||||
$response->content_type('text/html; charset=UTF-8');
|
||||
$response->header('Cache-Control' => 'private');
|
||||
# $response->no_cache(1); # TODO - re-enable this?
|
||||
$response->status($self->getStatus());
|
||||
# $response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
|
@ -407,18 +393,12 @@ sub setCookie {
|
|||
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);
|
||||
}
|
||||
$self->session->response->cookies->{$name} = {
|
||||
value => $value,
|
||||
path => '/',
|
||||
expires => $ttl ne 'session' ? $ttl : undef,
|
||||
domain => $domain,
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ package WebGUI::Session::Icon;
|
|||
use strict;
|
||||
use WebGUI::International;
|
||||
use Tie::IxHash;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
|
@ -127,20 +128,6 @@ sub cut {
|
|||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete ( urlParameters [, pageURL, confirmText ] )
|
||||
|
|
@ -511,7 +498,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -16,9 +16,10 @@ package WebGUI::Session::Id;
|
|||
=cut
|
||||
|
||||
use strict;
|
||||
use Digest::MD5;
|
||||
use Digest::MD5 ();
|
||||
use Time::HiRes qw( gettimeofday usleep );
|
||||
use MIME::Base64;
|
||||
use MIME::Base64 qw(encode_base64 decode_base64);
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
my $idValidator = qr/^[A-Za-z0-9_-]{22}$/;
|
||||
|
||||
|
|
@ -44,19 +45,6 @@ These methods are available from this class:
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 fromHex ( hexId )
|
||||
|
||||
Returns the guid corresponding to hexId. Converse of toHex.
|
||||
|
|
@ -121,7 +109,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -1,104 +0,0 @@
|
|||
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;
|
||||
|
|
@ -16,6 +16,7 @@ package WebGUI::Session::Output;
|
|||
|
||||
use strict;
|
||||
use WebGUI::Macro;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -36,20 +37,6 @@ These methods are available from this package:
|
|||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session )
|
||||
|
|
@ -65,7 +52,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -94,8 +83,16 @@ sub print {
|
|||
if (defined $handle) {
|
||||
print $handle $content;
|
||||
}
|
||||
elsif ($self->session->request) {
|
||||
$self->session->request->print($content);
|
||||
elsif ($self->session->response) {
|
||||
my $response = $self->session->response;
|
||||
if ($response->streaming) {
|
||||
$response->stream_write($content);
|
||||
} else {
|
||||
# Not streaming, so buffer the response instead
|
||||
# warn "buffering output";
|
||||
$response->body([]) unless $response->body && ref $response->body eq 'ARRAY';
|
||||
push @{$response->body}, $content;
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $content;
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ package WebGUI::Session::Privilege;
|
|||
use strict;
|
||||
use WebGUI::International;
|
||||
use WebGUI::Operation::Auth;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -64,21 +65,6 @@ sub adminOnly {
|
|||
return $self->session->style->userStyle($output);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 insufficient ( )
|
||||
|
|
@ -145,7 +131,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
40
lib/WebGUI/Session/Request.pm
Normal file
40
lib/WebGUI/Session/Request.pm
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
package WebGUI::Session::Request;
|
||||
use strict;
|
||||
use parent qw(Plack::Request);
|
||||
use WebGUI::Session::Response;
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $session = WebGUI::Session->open(...);
|
||||
my $request = $session->request;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
WebGUI's PSGI request utility class. Sub-classes L<Plack::Request>.
|
||||
|
||||
An instance of this object is created automatically when the L<WebGUI::Session>
|
||||
is created.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new_response ()
|
||||
|
||||
Creates a new L<WebGUI::Session::Response> object.
|
||||
|
||||
N.B. A L<WebGUI::Session::Response> object is automatically created when L<WebGUI::Session>
|
||||
is instantiated, so in most cases you will not need to call this method.
|
||||
See L<WebGUI::Session/response>
|
||||
|
||||
=cut
|
||||
|
||||
sub new_response {
|
||||
my $self = shift;
|
||||
return WebGUI::Session::Response->new(@_);
|
||||
}
|
||||
|
||||
# This is only temporary
|
||||
sub TRACE {
|
||||
shift->env->{'psgi.errors'}->print(join '', @_, "\n");
|
||||
}
|
||||
|
||||
1;
|
||||
36
lib/WebGUI/Session/Response.pm
Normal file
36
lib/WebGUI/Session/Response.pm
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
package WebGUI::Session::Response;
|
||||
use strict;
|
||||
use parent qw(Plack::Response);
|
||||
|
||||
use Plack::Util::Accessor qw(session streaming writer streamer);
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $session = WebGUI::Session->open(...);
|
||||
my $response = $session->response;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
WebGUI's PSGI response utility class. Sub-classes L<Plack::Response>.
|
||||
|
||||
An instance of this object is created automatically when the L<WebGUI::Session>
|
||||
is created.
|
||||
|
||||
=cut
|
||||
|
||||
sub stream {
|
||||
my $self = shift;
|
||||
$self->streamer(shift);
|
||||
$self->streaming(1);
|
||||
}
|
||||
|
||||
sub stream_write {
|
||||
my $self = shift;
|
||||
if (!$self->streaming) {
|
||||
Carp::carp("stream_write can only be called inside streaming response");
|
||||
return;
|
||||
}
|
||||
$self->writer->write(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -16,6 +16,7 @@ package WebGUI::Session::Scratch;
|
|||
|
||||
use strict;
|
||||
use WebGUI::International;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -138,21 +139,6 @@ sub deleteNameByValue {
|
|||
$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 )
|
||||
|
|
@ -198,11 +184,14 @@ The current session.
|
|||
|
||||
sub new {
|
||||
my ($class, $session) = @_;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
my $scratch = $session->cache->get("sessionscratch_".$session->getId);
|
||||
unless (ref $scratch eq "HASH") {
|
||||
$scratch = $session->db->buildHashRef("select name,value from userSessionScratch where sessionId=?",[$session->getId], {noOrder => 1});
|
||||
}
|
||||
bless {_session=>$session, _data=>$scratch}, $class;
|
||||
$self->{_data} = $scratch;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ package WebGUI::Session::Setting;
|
|||
=cut
|
||||
|
||||
use strict;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -67,21 +68,6 @@ sub add {
|
|||
$self->set(@_);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( $param )
|
||||
|
|
@ -145,8 +131,10 @@ A reference to the current WebGUI::Session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $settings = $session->db->buildHashRef("select * from settings", [], {noOrder => 1});
|
||||
bless {_settings=>$settings, _session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
$self->{_settings} = $session->db->buildHashRef("select * from settings", [], {noOrder => 1});
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ package WebGUI::Session::Stow;
|
|||
=cut
|
||||
|
||||
use strict;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -77,20 +78,6 @@ sub deleteAll {
|
|||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( varName )
|
||||
|
|
@ -155,7 +142,9 @@ A reference to the session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -16,12 +16,12 @@ package WebGUI::Session::Style;
|
|||
|
||||
|
||||
use strict;
|
||||
use Tie::CPHash;
|
||||
use WebGUI::International;
|
||||
use WebGUI::Macro;
|
||||
require WebGUI::Asset;
|
||||
BEGIN { eval { require WebGUI; WebGUI->import } }
|
||||
use HTML::Entities ();
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -56,19 +56,6 @@ These methods are available from this class:
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _generateAdditionalTags {
|
||||
my $var = shift;
|
||||
return sub {
|
||||
|
|
@ -181,7 +168,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session}, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ use URI;
|
|||
use URI::Escape;
|
||||
use WebGUI::International;
|
||||
use WebGUI::Utility;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
|
@ -93,20 +94,6 @@ sub append {
|
|||
return $url;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 escape ( string )
|
||||
|
|
@ -144,7 +131,7 @@ consecutive slashes in the path part of the URL will be replaced with a single s
|
|||
sub extras {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
my $url = $self->session->config->get("extrasURL");
|
||||
my $url = $self->session->url->make_urlmap_work($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'} } ) {
|
||||
|
|
@ -190,7 +177,7 @@ sub gateway {
|
|||
my $pageUrl = shift;
|
||||
my $pairs = shift;
|
||||
my $skipPreventProxyCache = shift;
|
||||
my $url = $self->session->config->get("gateway").'/'.$pageUrl;
|
||||
my $url = $self->make_urlmap_work($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());
|
||||
|
|
@ -198,7 +185,23 @@ sub gateway {
|
|||
if ($pairs) {
|
||||
$url = $self->append($url,$pairs);
|
||||
}
|
||||
|
||||
return $url;
|
||||
}
|
||||
|
||||
# Temporary hack
|
||||
sub make_urlmap_work {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
if (! $self->session->request) {
|
||||
return $url;
|
||||
}
|
||||
if (URI->new($url, 'http')->host) {
|
||||
return $url;
|
||||
}
|
||||
my $uri = $self->session->request->base;
|
||||
$uri->path($uri->path . $url);
|
||||
return $uri->path;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -322,7 +325,7 @@ sub getRequestedUrl {
|
|||
my $self = shift;
|
||||
return undef unless ($self->session->request);
|
||||
unless ($self->{_requestedUrl}) {
|
||||
$self->{_requestedUrl} = $self->session->request->uri;
|
||||
$self->{_requestedUrl} = $self->session->request->path_info; # TODO - is path_info right?
|
||||
my $gateway = $self->session->config->get("gateway");
|
||||
$self->{_requestedUrl} =~ s/^$gateway([^?]*)\??.*$/$1/;
|
||||
}
|
||||
|
|
@ -419,7 +422,9 @@ A reference to the current session.
|
|||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ package WebGUI::Session::Var;
|
|||
=cut
|
||||
|
||||
use strict;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -46,19 +47,6 @@ These methods are available from this package:
|
|||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 end ( )
|
||||
|
|
@ -75,7 +63,6 @@ sub end {
|
|||
$session->scratch->deleteAll;
|
||||
$session->db->write("delete from userSession where sessionId=?",[$id]);
|
||||
delete $session->{_user};
|
||||
$self->DESTROY;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -171,7 +158,8 @@ normally be used by anyone.
|
|||
|
||||
sub new {
|
||||
my ($class, $session, $sessionId, $noFuss) = @_;
|
||||
my $self = bless {_session=>$session}, $class;
|
||||
my $self = bless { _session => $session }, $class;
|
||||
weaken $self->{_session};
|
||||
if ($sessionId eq "") { ##New session
|
||||
$self->start(1);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -91,7 +91,6 @@ Removes this address from the book.
|
|||
sub delete {
|
||||
my $self = shift;
|
||||
$self->addressBook->session->db->deleteRow("address","addressId",$self->getId);
|
||||
undef $self;
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -91,7 +91,6 @@ sub delete {
|
|||
$address->delete;
|
||||
}
|
||||
$self->session->db->write("delete from addressBook where addressBookId=?",[$self->getId]);
|
||||
undef $self;
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -182,7 +182,6 @@ sub delete {
|
|||
$item->delete;
|
||||
}
|
||||
$self->session->db->write("delete from transaction where transactionId=?",[$self->getId]);
|
||||
undef $self;
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -74,7 +74,6 @@ Removes this item from the transaction.
|
|||
sub delete {
|
||||
my $self = shift;
|
||||
$self->transaction->session->db->deleteRow("transactionItem","itemId",$self->getId);
|
||||
undef $self;
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -365,8 +365,6 @@ sub addFileFromFormPost {
|
|||
my $session = $self->session;
|
||||
return ""
|
||||
if ($self->session->http->getStatus eq '413');
|
||||
require Apache2::Request;
|
||||
require Apache2::Upload;
|
||||
my $filename;
|
||||
my $attachmentCount = 1;
|
||||
foreach my $upload ($session->request->upload($formVariableName)) {
|
||||
|
|
@ -1278,7 +1276,7 @@ If specified, we'll return a URL to the file rather than the storage location.
|
|||
sub getUrl {
|
||||
my $self = shift;
|
||||
my $file = shift;
|
||||
my $url = $self->session->config->get("uploadsURL") . '/' . $self->getPathFrag;
|
||||
my $url = $self->session->url->make_urlmap_work($self->session->config->get("uploadsURL")) . '/' . $self->getPathFrag;
|
||||
my $cdnCfg = $self->session->config->get('cdn');
|
||||
if ( $cdnCfg
|
||||
and $cdnCfg->{'enabled'}
|
||||
|
|
|
|||
|
|
@ -1,119 +0,0 @@
|
|||
package WebGUI::URL::Content;
|
||||
|
||||
=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 Apache2::Const -compile => qw(OK DECLINED);
|
||||
use WebGUI::Affiliate;
|
||||
use WebGUI::Exception;
|
||||
use WebGUI::Pluggable;
|
||||
use WebGUI::Session;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::URL::Content
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A URL handler that does whatever I tell it to do.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::URL::Content;
|
||||
my $status = WebGUI::URL::Content::handler($r, $s, $config);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 handler ( request, server, config )
|
||||
|
||||
The Apache request handler for this package.
|
||||
|
||||
This handler takes care of certain special tokens returns by a sub-handler.
|
||||
|
||||
=head3 chunked
|
||||
|
||||
This indicates that the handler has already returned the output to Apache. Commonly
|
||||
used in Assets to get head tags back to the user to speed up the rendering process.
|
||||
|
||||
=head3 empty
|
||||
|
||||
This token indicates that the asset is legitimatally empty. Returns nothing
|
||||
to the user, instead of displaying the Page Not Found page.
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my ($request, $server, $config) = @_;
|
||||
$request->push_handlers(PerlResponseHandler => sub {
|
||||
my $session = $request->pnotes('wgSession');
|
||||
WEBGUI_FATAL: {
|
||||
unless (defined $session) {
|
||||
$session = WebGUI::Session->open($config, $request, $server);
|
||||
return Apache2::Const::OK if ! defined $session;
|
||||
}
|
||||
foreach my $handler (@{$config->get("contentHandlers")}) {
|
||||
my $output = eval { WebGUI::Pluggable::run($handler, "handler", [ $session ] )};
|
||||
if ( my $e = WebGUI::Error->caught ) {
|
||||
$session->errorHandler->error($e->package.":".$e->line." - ".$e->error);
|
||||
$session->errorHandler->debug($e->package.":".$e->line." - ".$e->trace);
|
||||
}
|
||||
elsif ( $@ ) {
|
||||
$session->errorHandler->error( $@ );
|
||||
}
|
||||
else {
|
||||
if ($output eq "chunked") {
|
||||
if ($session->errorHandler->canShowDebug()) {
|
||||
$session->output->print($session->errorHandler->showDebug(),1);
|
||||
}
|
||||
last;
|
||||
}
|
||||
if ($output eq "empty") {
|
||||
if ($session->errorHandler->canShowDebug()) {
|
||||
$session->output->print($session->errorHandler->showDebug(),1);
|
||||
}
|
||||
last;
|
||||
}
|
||||
elsif (defined $output && $output ne "") {
|
||||
$session->http->sendHeader;
|
||||
$session->output->print($output);
|
||||
if ($session->errorHandler->canShowDebug()) {
|
||||
$session->output->print($session->errorHandler->showDebug(),1);
|
||||
}
|
||||
last;
|
||||
}
|
||||
# Keep processing for success codes
|
||||
elsif ($session->http->getStatus < 200 || $session->http->getStatus > 299) {
|
||||
$session->http->sendHeader;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$session->close if defined $session;
|
||||
return Apache2::Const::OK;
|
||||
});
|
||||
$request->push_handlers(PerlMapToStorageHandler => sub { return Apache2::Const::OK });
|
||||
$request->push_handlers(PerlTransHandler => sub { return Apache2::Const::OK });
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
package WebGUI::URL::PassThru;
|
||||
|
||||
=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 Apache2::Const -compile => qw(OK DECLINED DIR_MAGIC_TYPE);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::URL::PassThru
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A URL handler that just passes the URLs back to Apache.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::URL::PassThru;
|
||||
my $status = WebGUI::URL::PassThru::handler($r, $s, $config);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 handler ( request, server, config )
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my ($request, $server, $config) = @_;
|
||||
if ($request->handler eq 'perl-script' && # Handler is Perl
|
||||
-d $request->filename && # Filename requested is a directory
|
||||
$request->is_initial_req) # and this is the initial request
|
||||
{
|
||||
$request->handler(Apache2::Const::DIR_MAGIC_TYPE); # Hand off to mod_dir
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
package WebGUI::URL::Snoop;
|
||||
|
||||
=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 Apache2::Const -compile => qw(OK DECLINED);
|
||||
use WebGUI::Session;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::URL::Snoop
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A URL handler that should never be called.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::URL::Snoop;
|
||||
my $status = WebGUI::URL::Snoop::handler($r, $configFile);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 handler ( request, configFile )
|
||||
|
||||
The Apache request handler for this package.
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my ($request, $server, $config) = @_;
|
||||
$request->content_type("text/html");
|
||||
$request->push_handlers(PerlResponseHandler => sub {
|
||||
$request->print(q|<html><head><title>Snoopy</title></head><body><div style="width: 600px; padding: 200px;">Why would you type in this URL? Really. What were you expecting to see here? You really need to get a life. Are you still here? Seriously, you need to go do something else. I think your boss is calling.</div></body></html>|);
|
||||
return Apache2::Const::OK;
|
||||
} );
|
||||
$request->push_handlers(PerlTransHandler => sub { return Apache2::Const::OK });
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
package WebGUI::URL::Unauthorized;
|
||||
|
||||
=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 Apache2::Const -compile => qw(AUTH_REQUIRED);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::URL::Unauthorized
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A URL handler that deals with requests where the user cannot access what they requested.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::URL::Unauthorized;
|
||||
my $status = WebGUI::URL::Unauthorized::handler($r, $s, $config);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 handler ( request, server, config )
|
||||
|
||||
The Apache request handler for this package.
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my ($request, $server, $config) = @_;
|
||||
return Apache2::Const::AUTH_REQUIRED;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -1,107 +0,0 @@
|
|||
package WebGUI::URL::Uploads;
|
||||
|
||||
=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 Apache2::Const -compile => qw(OK DECLINED NOT_FOUND AUTH_REQUIRED);
|
||||
use WebGUI::Session;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::URL::Uploads;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A URL handler that handles privileges for uploaded files.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::URL::Uploads;
|
||||
my $status = WebGUI::URL::Uploads::handler($r, $s, $config);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 handler ( request, server, config )
|
||||
|
||||
The Apache request handler for this package.
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my ($request, $server, $config) = @_;
|
||||
$request->push_handlers(PerlAccessHandler => sub {
|
||||
my $path = $request->filename;
|
||||
return Apache2::Const::NOT_FOUND
|
||||
unless -e $path;
|
||||
$path =~ s{[^/]*$}{};
|
||||
return Apache2::Const::OK
|
||||
unless -e $path . '.wgaccess';
|
||||
|
||||
open my $FILE, '<' , $path . '.wgaccess';
|
||||
my $fileContents = do { local $/; <$FILE> };
|
||||
close($FILE);
|
||||
my @users;
|
||||
my @groups;
|
||||
my @assets;
|
||||
if ($fileContents =~ /\A(?:\d+|[A-Za-z0-9_-]{22})\n(?:\d+|[A-Za-z0-9_-]{22})\n(?:\d+|[A-Za-z0-9_-]{22})/) {
|
||||
my @privs = split("\n", $fileContents);
|
||||
push @users, $privs[0];
|
||||
push @groups, @privs[1,2];
|
||||
}
|
||||
else {
|
||||
my $privs = JSON->new->decode($fileContents);
|
||||
@users = @{ $privs->{users} };
|
||||
@groups = @{ $privs->{groups} };
|
||||
@assets = @{ $privs->{assets} };
|
||||
}
|
||||
|
||||
return Apache2::Const::OK
|
||||
if grep { $_ eq '1' } @users;
|
||||
|
||||
return Apache2::Const::OK
|
||||
if grep { $_ eq '1' || $_ eq '7' } @groups;
|
||||
|
||||
my $session = $request->pnotes('wgSession');
|
||||
unless (defined $session) {
|
||||
$session = WebGUI::Session->open($config->getFilename, $request, $server);
|
||||
}
|
||||
|
||||
my $userId = $session->var->get('userId');
|
||||
|
||||
return Apache2::Const::OK
|
||||
if grep { $_ eq $userId } @users;
|
||||
|
||||
my $user = $session->user;
|
||||
|
||||
return Apache2::Const::OK
|
||||
if grep { $user->isInGroup($_) } @groups;
|
||||
|
||||
return Apache2::Const::OK
|
||||
if grep { WebGUI::Asset->new($session, $_)->canView } @assets;
|
||||
|
||||
return Apache2::Const::AUTH_REQUIRED;
|
||||
} );
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
package WebGUI::URL::MyHandler;
|
||||
|
||||
=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 Apache2::Const -compile => qw(OK DECLINED NOT_FOUND);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::URL::MyHandler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A URL handler that does whatever I tell it to do.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::URL::MyHandler;
|
||||
my $status = WebGUI::URL::MyHandler::handler($r, $configFile);
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
These subroutines are available from this package:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 handler ( request, server, config )
|
||||
|
||||
The Apache request handler for this package.
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my ($request, $server, $config) = @_;
|
||||
# ...
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
|
||||
1;
|
||||
#vim:ft=perl
|
||||
|
|
@ -163,21 +163,6 @@ sub demoteActivity {
|
|||
}
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( name )
|
||||
|
|
|
|||
|
|
@ -169,23 +169,8 @@ sub delete {
|
|||
my $sth = $self->session->db->prepare("delete from WorkflowActivityData where activityId=?");
|
||||
$sth->execute([$self->getId]);
|
||||
$self->session->db->deleteRow("WorkflowActivity","activityId",$self->getId);
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 execute ( object, instance )
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@ use HTTP::Request;
|
|||
use HTTP::Request::Common qw(POST);
|
||||
use LWP::UserAgent;
|
||||
use Digest::MD5;
|
||||
use Apache2::ServerUtil;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -80,7 +79,7 @@ sub execute {
|
|||
my $stats = {
|
||||
webguiVersion => $WebGUI::VERSION,
|
||||
perlVersion => sprintf("%vd", $^V),
|
||||
apacheVersion => Apache2::ServerUtil::get_server_version(),
|
||||
apacheVersion => 'X',
|
||||
osType => $^O,
|
||||
siteId => Digest::MD5::md5_base64($self->session->config->get("sitename")->[0]), # only here to identify the site if the user submits their info a second time
|
||||
userCount => $db->quickScalar("select count(*) from users"),
|
||||
|
|
|
|||
|
|
@ -87,23 +87,8 @@ sub delete {
|
|||
if (! $skipNotify) {
|
||||
WebGUI::Workflow::Spectre->new($self->session)->notify("cron/deleteJob", $self->session->config->getFilename."-".$self->getId);
|
||||
}
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get ( name )
|
||||
|
|
|
|||
|
|
@ -106,7 +106,6 @@ sub delete {
|
|||
$self->session->db->write("delete from WorkflowInstanceScratch where instanceId=?",[$self->getId]);
|
||||
$self->session->db->deleteRow("WorkflowInstance","instanceId",$self->getId);
|
||||
WebGUI::Workflow::Spectre->new($self->session)->notify("workflow/deleteInstance",$self->getId) unless ($skipNotify);
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -143,7 +142,6 @@ sub DESTROY {
|
|||
$self->start;
|
||||
}
|
||||
delete $self->{_workflow};
|
||||
undef $self;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -39,19 +39,6 @@ These methods are available from this class:
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 DESTROY ( )
|
||||
|
||||
Deconstructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
undef $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 notify ( module, params )
|
||||
|
||||
Sends a message to Spectre.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue