oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'psgi' into WebGUI8

Browse source
This commit is contained in:
Graham Knop 2010-06-11 23:05:06 -05:00
commit 89d4f46a18
94 changed files with 2002 additions and 2269 deletions
Download patch file Download diff file Expand all files Collapse all files

33
README Normal file
View file

@ -0,0 +1,33 @@
This is the PSGI branch of WebGUI8
To try this out:
1) Run testEnvironment.pl to install Plack
2) $ cd <WebGUI directory>
3) $ plackup app.psgi
Currently, the best performance is achieved via:
plackup -E none -s Starman --workers 10 --disable-keepalive
You can benchmark your server via:
ab -t 3 -c 10 -k http://dev.localhost.localdomain:5000/ | grep Req
I'm currently getting 370 requests/second, whereas I'm getting 430/second on the non-PSGI WebGUI8 branch.
= ARCHITECTURE =
* The root level app.psgi file loads all the config files found and
loads the site specific psgi file for each, linking them to the
proper host names.
* The site psgi file uses the WEBGUI_CONFIG environment variable to find the config.
* It instantiates the $wg WebGUI object (one per app).
* $wg creates and stores the WebGUI::Config (one per app)
* $wg creates the $app PSGI app code ref (one per app)
* WebGUI::Middleware::Session is wrapped around $app at the outer-most layer so that it can open and
close the $session WebGUI::Session. Any other wG middleware that needs $session should go in between
it and $app ($session created one per request)
* $session creates the $request WebGUI::Session::Request and $response WebGUI::Session::Response
objects (one per request)

21
TODO Normal file
View file

@ -0,0 +1,21 @@
TODO
* Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response
* Investigate moving Cookie handling into middleware
* Reinstate WebGUI::authen with something equivalent
* Refactor assets to use streaming response
* Fix WebGUI::Form::param
DONE
* $session->request is now a Plack::Request object
* serverObject gone from WebGUI::Session::open()
* WebGUI::authen API changed
* urlHandler API changed - no longer gets server, config
* Streaming response body
* Mostly decoupled WebGUI from Log4perl
* Exception handling and error doc mapping
* Plack::Middleware::Debug panels
* Replaces all URL Handlers with Middleware
NB
* Periodically do a big stress-test and check for leaks, mysql overload etc..
ab -t 100 -c 10 -k http://dev.localhost.localdomain:5000 | grep 'Req'

161
WebGUI-Session-Plack.pm Normal file
View file

@ -0,0 +1,161 @@
package WebGUI::Session::Plack;
# This file is deprecated - keeping it here for reference until everything has been ported
use strict;
use warnings;
use Carp;
=head1 DESCRIPTION
This class is used instead of WebGUI::Session::Request when wg is started via plackup
=cut
sub new {
my ( $class, %p ) = @_;
# 'require' rather than 'use' so that non-plebgui doesn't freak out
require Plack::Request;
my $request = Plack::Request->new( $p{env} );
my $response = $request->new_response(200);
bless {
%p,
pnotes => {},
request => $request,
response => $response,
server => WebGUI::Session::Plack::Server->new( env => $p{env} ),
headers_out => Plack::Util::headers( [] ), # use Plack::Util to manage response headers
body => [],
sendfile => undef,
}, $class;
}
our $AUTOLOAD;
sub AUTOLOAD {
my $what = $AUTOLOAD;
$what =~ s/.*:://;
carp "!!plack->$what(@_)" unless $what eq 'DESTROY';
}
# Emulate/delegate/fake Apache2::* subs
sub uri { shift->{request}->path_info }
sub param { shift->{request}->param(@_) }
sub params { shift->{request}->prameters->mixed(@_) }
sub headers_in { shift->{request}->headers(@_) }
sub headers_out { shift->{headers_out} }
sub protocol { shift->{request}->protocol(@_) }
sub status { shift->{response}->status(@_) }
sub sendfile { $_[0]->{sendfile} = $_[1] }
sub server { shift->{server} }
sub method { shift->{request}->method }
sub upload { shift->{request}->upload(@_) }
sub dir_config { shift->{server}->dir_config(@_) }
sub status_line { }
sub auth_type { } # should we support this?
sub handler {'perl-script'} # or not..?
sub content_type {
my ( $self, $ct ) = @_;
$self->{headers_out}->set( 'Content-Type' => $ct );
}
# TODO: I suppose this should do some sort of IO::Handle thing
sub print {
my $self = shift;
push @{ $self->{body} }, @_;
}
sub pnotes {
my ( $self, $key ) = ( shift, shift );
return wantarray ? %{ $self->{pnotes} } : $self->{pnotes} unless defined $key;
return $self->{pnotes}{$key} = $_[0] if @_;
return $self->{pnotes}{$key};
}
sub user {
my ( $self, $user ) = @_;
if ( defined $user ) {
$self->{user} = $user;
}
$self->{user};
}
sub push_handlers {
my $self = shift;
my ( $x, $sub ) = @_;
# log it
# carp "push_handlers($x)";
# run it
# returns something like Apache2::Const::OK, which we just ignore because we're not modperl
my $ret = $sub->($self);
return;
}
sub finalize {
my $self = shift;
my $response = $self->{response};
if ( $self->{sendfile} && open my $fh, '<', $self->{sendfile} ) {
$response->body($fh);
}
else {
$response->body( $self->{body} );
}
$response->headers( $self->{headers_out}->headers );
return $response->finalize;
}
sub no_cache {
my ( $self, $doit ) = @_;
if ($doit) {
$self->{headers_out}->set( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' );
}
else {
$self->{headers_out}->remove( 'Pragma', 'Cache-control' );
}
}
################################################
package WebGUI::Session::Plack::Server;
use strict;
use warnings;
use Carp;
sub new {
my $class = shift;
bless {@_}, $class;
}
our $AUTOLOAD;
sub AUTOLOAD {
my $what = $AUTOLOAD;
$what =~ s/.*:://;
carp "!!server->$what(@_)" unless $what eq 'DESTROY';
}
sub dir_config {
my ( $self, $c ) = @_;
# Translate the legacy WebguiRoot and WebguiConfig PerlSetVar's into known values
return WebGUI->root if $c eq 'WebguiRoot';
return WebGUI->config_file if $c eq 'WebguiConfig';
# Otherwise, we might want to provide some sort of support (which Apache is still around)
return $self->{env}->{"wg.DIR_CONFIG.$c"};
}
################################################
package Plack::Request::Upload;
sub link { shift->link_to(@_) }
1;

29
app.psgi Normal file
View file

@ -0,0 +1,29 @@
use strict;
use Plack::Builder;
use WebGUI::Paths -inc;
use WebGUI::Config;
if ($ENV{PLACK_ENV} ne 'development') {
WebGUI::Paths->preloadAll;
}
builder {
my $first_app;
for my $config_file (WebGUI::Paths->siteConfigs) {
my $config = WebGUI::Config->new($config_file);
my $psgi = $config->get('psgiFile') || WebGUI::Paths->defaultPSGI;
my $app = do {
# default psgi file uses environment variable to find config file
local $ENV{WEBGUI_CONFIG} = $config_file;
Plack::Util::load_psgi($psgi);
};
$first_app ||= $app;
for my $sitename ( @{ $config->get('sitename') } ) {
mount "http://$sitename/" => $app;
}
}
# use the first config found as a fallback
mount '/' => $first_app;
};

19
benchmark.pl Executable file
View file

@ -0,0 +1,19 @@
# Little script used to run benchmarks against dev.localhost.localdomain
#
# To profile, run "perl -d:NYTProf benchmark.pl"
use lib '/data/WebGUI/lib';
use WebGUI;
use Plack::Test;
use Plack::Builder;
use HTTP::Request::Common;
my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' );
my $app = builder {
enable '+WebGUI::Middleware::Session', config => $wg->config;
$wg;
};
test_psgi $app, sub {
my $cb = shift;
$cb->( GET "/" ) for 1..1000;
};

23
eg/README Normal file
View file

@ -0,0 +1,23 @@
# Some ways to achieve the same thing from the command line:
# plackup -MWebGUI -e 'WebGUI->new'
# plackup -MWebGUI -e 'WebGUI->new("dev.localhost.localdomain.conf")'
# plackup -MWebGUI -e 'WebGUI->new(root => "/data/WebGUI", site => "dev.localhost.localdomain.conf")'
#
# Or from a .psgi file:
# my $app = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' )->psgi_app;
# Extras
my $extrasURL = $wg->config->get('extrasURL');
my $extrasPath = $wg->config->get('extrasPath');
enable 'Plack::Middleware::Static',
path => sub { s{^$extrasURL/}{} },
root => "$extrasPath/";
# Uploads
my $uploadsURL = $wg->config->get('uploadsURL');
my $uploadsPath = $wg->config->get('uploadsPath');
enable 'Plack::Middleware::Static',
path => sub { s{^$uploadsURL/}{} },
root => "$uploadsPath/";

27
eg/apache.conf Normal file
View file

@ -0,0 +1,27 @@
<VirtualHost *:80>
PerlOptions +Parent
PerlSwitches -I/data/WebGUI/lib
# CGI
#AddHandler cgi-script cgi
#ScriptAlias / /data/WebGUI/etc/dev.localhost.localdomain.cgi/
#<Directory /data/WebGUI/etc>
# Options +ExecCGI
#</Directory>
# Apache2
#SetHandler perl-script
#PerlHandler Plack::Server::Apache2
#PerlSetVar psgi_app /data/WebGUI/etc/dev.localhost.localdomain.psgi
# FastCGI
FastCgiServer /data/WebGUI/etc/dev.localhost.localdomain.fcgi
ScriptAlias / /data/WebGUI/etc/dev.localhost.localdomain.fcgi/
# mod_psgi
#<Location />
# SetHandler psgi
# PSGIApp /data/WebGUI/etc/dev.localhost.localdomain.psgi
#</Location>
</VirtualHost>

5
eg/dev.localhost.localdomain.cgi Executable file
View file

@ -0,0 +1,5 @@
#!/usr/bin/perl
use Plack::Server::CGI;
my $app = Plack::Util::load_psgi("/data/WebGUI/etc/dev.localhost.localdomain.psgi");
Plack::Server::CGI->new->run($app);

5
eg/dev.localhost.localdomain.fcgi Executable file
View file

@ -0,0 +1,5 @@
#!/usr/bin/perl
use Plack::Server::FCGI;
my $app = Plack::Util::load_psgi("../app.psgi");
Plack::Server::FCGI->new->run($app);

7
eg/dev.localhost.localdomain.perlbal Normal file
View file

@ -0,0 +1,7 @@
LOAD PSGI
CREATE SERVICE psgi
SET role = web_server
SET listen = 127.0.0.1:80
SET plugins = psgi
PSGI_APP = dev.localhost.localdomain.psgi
ENABLE psgi

20
eg/urlmap.psgi Normal file
View file

@ -0,0 +1,20 @@
use lib '/data/WebGUI/lib';
use WebGUI;
my $wg1 = WebGUI->new;
my $wg2 = WebGUI->new;
use Plack::Builder;
my $app = builder {
mount "http://dev.localhost.localdomain:5000/" => $wg1;
mount "/wg1" => $wg1;
mount "/wg2" => $wg2;
mount "/" => sub { [ 200, [ 'Content-Type' => 'text/html' ], [ <<END_HTML ] ] };
<p>WebGUI + URLMap</p>
<ul>
<li><a href="http://dev.localhost.localdomain:5000">Virtual Host (wG instance #1)</a></li>
<li><a href=/wg1>Nested (wG instance #1)</a></li>
<li><a href=/wg2>Nested (wG instance #2)</a></li>
</ul>
END_HTML
};

38
lib/Plack/Middleware/Debug/Logger.pm Normal file
View file

@ -0,0 +1,38 @@
package Plack::Middleware::Debug::Logger;
use 5.008;
use strict;
use warnings;
use parent qw(Plack::Middleware::Debug::Base);
our $VERSION = '0.07';
sub run {
my ($self, $env, $panel) = @_;
my $logger = $env->{'psgix.logger'};
my $log_output = [];
$env->{'psgix.logger'} = sub {
my ($args) = @_;
my $caller = (caller(1))[3] . '[' . (caller(0))[2] . '] ';
my $message = $args->{message};
push @$log_output, $args->{level} => $caller . $message;
if ($logger) {
goto $logger;
}
};
return sub {
my $res = shift;
if ($logger) {
$env->{'psgix.logger'} = $logger;
}
$panel->nav_subtitle(scalar @$log_output / 2 . ' messages');
if (@$log_output) {
$panel->content('<div style="white-space: pre">' . $self->render_list_pairs( $log_output ) . '</div>');
}
};
}
1;

103
lib/Plack/Middleware/Debug/MySQLTrace.pm Normal file
View file

@ -0,0 +1,103 @@
package Plack::Middleware::Debug::MySQLTrace;
use 5.008;
use strict;
use warnings;
use parent qw(Plack::Middleware::Debug::Base);
use Plack::Util::Accessor qw(skip_packages);
use Sub::Uplevel ();
our $VERSION = '0.07';
sub run {
my($self, $env, $panel) = @_;
my $old_trace;
my @output;
my $queries = 0;
if (defined &DBI::trace) {
$old_trace = DBI->trace;
open my $trace_handle, '>:via(Plack::Middleware::Debug::MySQLTrace::IO)', {
skip_packages => $self->skip_packages,
logger => sub {
my $sql = shift;
$sql =~ s/\s+\z//;
$sql =~ s/\A\s+//;
$queries++;
push @output, sprintf('%s - %s[%s]', $queries, (caller 1)[3], (caller 0)[2]), $sql;
},
};
DBI->trace('2,SQL', $trace_handle);
}
else {
return $panel->disable;
}
return sub {
my $res = shift;
if (defined $old_trace) {
DBI->trace($old_trace);
$panel->title('MySQL Trace');
$panel->nav_title('MySQL Trace');
$panel->nav_subtitle($queries . ' Queries');
$panel->content('<div style="white-space: pre; font-family: monospace">' . $self->render_list_pairs(\@output) . '</div>');
}
};
}
package Plack::Middleware::Debug::MySQLTrace::IO;
use strict;
use 5.008;
our $VERSION = '0.01';
sub PUSHED {
my ($class, $mode, $fh) = @_;
return bless {}, $class;
}
sub OPEN {
my ($self, $logger, $mode, $fh) = @_;
%$self = %$logger;
return 1;
}
sub WRITE {
my ($self, $buf, $fh) = @_;
if ($buf =~ /\ABinding parameters: /) {
my $sql = $buf;
$sql =~ s/\ABinding parameters: //;
my $depth;
for ( $depth = 1; caller($depth); $depth++) {
my $package = caller($depth);
next
if $package =~ /\ADB[ID](?:\z|::)/;
next
if $package =~ /::(?:st|db)\z/;
next
if $self->{skip_packages} && $package =~ $self->{skip_packages};
last;
}
Sub::Uplevel::uplevel $depth + 1, $self->{logger}, $sql;
}
return length($buf);
}
sub CLOSE {
my $self = shift;
return 0;
}
1;
__END__
=head1 NAME
Plack::Middleware::Debug::MySQLTrace - DBI MySQL trace panel
=head1 SEE ALSO
L<Plack::Middleware::Debug>
=cut

1
lib/Spectre/Cron.pm
View file

@ -49,7 +49,6 @@ Gracefully shuts down the scheduler.
sub _stop {
my ($kernel, $self) = @_[KERNEL, OBJECT];
$self->debug("Stopping the scheduler.");
undef $self;
}
#-------------------------------------------------------------------

1
lib/Spectre/Workflow.pm
View file

@ -50,7 +50,6 @@ Gracefully shuts down the workflow manager.
sub _stop {
my ($kernel, $self) = @_[KERNEL, OBJECT];
$self->debug("Stopping workflow manager.");
undef $self;
}
#-------------------------------------------------------------------

282
lib/WebGUI.pm
View file

@ -20,18 +20,14 @@ our $STATUS = 'beta';
=cut
use strict;
use Apache2::Access ();
use Apache2::Const -compile => qw(OK DECLINED HTTP_UNAUTHORIZED SERVER_ERROR);
use Apache2::Request;
use Apache2::RequestIO;
use Apache2::RequestUtil ();
use Apache2::ServerUtil ();
use APR::Request::Apache2;
use MIME::Base64 ();
use Moose;
use MooseX::NonMoose;
use WebGUI::Config;
use WebGUI::Pluggable;
use WebGUI::Session;
use WebGUI::User;
use WebGUI::Paths;
use Try::Tiny;
extends 'Plack::Component';
=head1 NAME
@ -39,7 +35,7 @@ Package WebGUI
=head1 DESCRIPTION
An Apache mod_perl handler for WebGUI.
PSGI handler for WebGUI.
=head1 SYNOPSIS
@ -51,164 +47,144 @@ These subroutines are available from this package:
=cut
#-------------------------------------------------------------------
has config => (
is => 'rw',
isa => 'WebGUI::Config',
);
has site => (
is => 'ro',
isa => 'Str',
required => 1,
trigger => sub {
my ($self, $site) = @_;
my $config = WebGUI::Config->new( $site );
$self->config($config);
},
);
=head2 authen ( requestObject, [ user, pass, config ])
# Each web request results in a call to this sub
sub call {
my $self = shift;
my $env = shift;
HTTP Basic auth for WebGUI.
# Use the PSGI callback style response, which allows for nice things like
# delayed response/streaming body (server push). For now we just use this for
# unbuffered response writing
return sub {
my $responder = shift;
my $session = $env->{'webgui.session'}
or die 'Missing WebGUI Session - check WebGUI::Middleware::Session';
=head3 requestObject
# Handle the request
$self->handle($session);
The Apache2::RequestRec object passed in by Apache's mod_perl.
# Construct the PSGI response
my $response = $session->response;
my $psgi_response = $response->finalize;
=head3 user
# See if the content handler is doing unbuffered response writing
if ( $response->streaming ) {
try {
# Ask PSGI server for a streaming writer object by returning only the first
# two elements of the array reference
my $writer = $responder->( [ $psgi_response->[0], $psgi_response->[1] ] );
The username to authenticate with. Will pull from the request object if not specified.
# Store the writer object in the WebGUI::Session::Response object
$response->writer($writer);
=head3 pass
# Now call the callback that does the streaming
$response->streamer->($session);
The password to authenticate with. Will pull from the request object if not specified.
=head3 config
A reference to a WebGUI::Config object. One will be created if it isn't specified.
=cut
sub authen {
my ($request, $username, $password, $config) = @_;
$request = Apache2::Request->new($request);
my $server = Apache2::ServerUtil->server;
my $status = Apache2::Const::OK;
# set username and password if it's an auth handler
if ($username eq "") {
if ($request->auth_type eq "Basic") {
($status, $password) = $request->get_basic_auth_pw;
$username = $request->user;
}
else {
return Apache2::Const::HTTP_UNAUTHORIZED;
}
}
$config ||= WebGUI::Config->new($request->dir_config('WebguiConfig'));
my $cookies = APR::Request::Apache2->handle($request)->jar();
# determine session id
my $sessionId = $cookies->{$config->getCookieName};
my $session = WebGUI::Session->open($config, $request, $server, $sessionId);
my $log = $session->log;
$request->pnotes(wgSession => $session);
if (defined $sessionId && $session->user->isRegistered) { # got a session id passed in or from a cookie
$log->info("BASIC AUTH: using cookie");
return Apache2::Const::OK;
}
elsif ($status != Apache2::Const::OK) { # prompt the user for their username and password
$log->info("BASIC AUTH: prompt for user/pass");
return $status;
}
elsif (defined $username && $username ne "") { # no session cookie, let's try to do basic auth
$log->info("BASIC AUTH: using user/pass");
my $user = WebGUI::User->newByUsername($session, $username);
if (defined $user) {
my $authMethod = $user->authMethod;
if ($authMethod) { # we have an auth method, let's try to instantiate
my $auth = eval { WebGUI::Pluggable::instanciate("WebGUI::Auth::".$authMethod, "new", [ $session, $authMethod ] ) };
if ($@) { # got an error
$log->error($@);
return Apache2::Const::SERVER_ERROR;
}
elsif ($auth->authenticate($username, $password)) { # lets try to authenticate
$log->info("BASIC AUTH: authenticated successfully");
$sessionId = $session->db->quickScalar("select sessionId from userSession where userId=?",[$user->userId]);
unless (defined $sessionId) { # no existing session found
$log->info("BASIC AUTH: creating new session");
$sessionId = $session->id->generate;
$auth->_logLogin($user->userId, "success (HTTP Basic)");
}
$session->{_var} = WebGUI::Session::Var->new($session, $sessionId);
$session->user({user=>$user});
return Apache2::Const::OK;
}
}
}
$log->security($username." failed to login using HTTP Basic Authentication");
$request->note_basic_auth_failure;
return Apache2::Const::HTTP_UNAUTHORIZED;
}
$log->info("BASIC AUTH: skipping");
return Apache2::Const::HTTP_UNAUTHORIZED;
# And finally, clean up
$writer->close;
}
catch {
if ($response->writer) {
# Response has already been started, so log error and close writer
$session->request->TRACE("Error detected after streaming response started");
$response->writer->close;
}
else {
$responder->( [ 500, [ 'Content-Type' => 'text/plain' ], [ "Internal Server Error" ] ] );
}
};
}
else {
# Not streaming, so immediately tell the callback to return
# the response. In the future we could use an Event framework here
# to make this a non-blocking delayed response.
$responder->($psgi_response);
}
};
}
#-------------------------------------------------------------------
sub handle {
my ( $self, $session ) = @_;
# uncomment the following to short-circuit contentHandlers (for benchmarking PSGI scaffolding vs. modperl)
# $session->output->print("WebGUI PSGI with contentHandlers short-circuited for benchmarking\n");
# return;
=head2 handler ( requestObject )
# contentHandlers that return text will have that content returned as the response
# Alternatively, contentHandlers can stream the response body by calling:
# $session->response->stream_write()
# inside of a callback registered via:
# $session->response->stream( sub { } )
# This is generally a good thing to do, unless you want to send a file.
Primary http init/response handler for WebGUI. This method decides whether to hand off the request to contentHandler() or uploadsHandler()
=head3 requestObject
The Apache2::RequestRec object passed in by Apache's mod_perl.
=cut
sub handler {
my $request = shift; #start with apache request object
$request = Apache2::Request->new($request);
my $configFile = shift || $request->dir_config('WebguiConfig'); #either we got a config file, or we'll build it from the request object's settings
my $server = Apache2::ServerUtil->server; #instantiate the server api
my $config = WebGUI::Config->new($configFile); #instantiate the config object
my $error = "";
my $matchUri = $request->uri;
my $gateway = $config->get("gateway");
$matchUri =~ s{^$gateway}{/};
my $gotMatch = 0;
# handle basic auth
my $auth = $request->headers_in->{'Authorization'};
if ($auth =~ m/^Basic/) { # machine oriented
# Get username and password from Apache and hand over to authen
$auth =~ s/Basic //;
authen($request, split(":", MIME::Base64::decode_base64($auth), 2), $config);
}
else { # realm oriented
$request->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($request, undef, undef, $config)});
}
# url handlers
WEBGUI_FATAL: foreach my $handler (@{$config->get("urlHandlers")}) {
my ($regex) = keys %{$handler};
if ($matchUri =~ m{$regex}i) {
my $output = eval { WebGUI::Pluggable::run($handler->{$regex}, "handler", [$request, $server, $config]) };
if ($@) {
$error = $@;
last;
# uncomment the following to short-circuit contentHandlers with a streaming response:
# $session->response->stream(
# sub {
# my $session = shift;
# $session->output->print("WebGUI PSGI with contentHandlers short-circuited for benchmarking (streaming)\n");
# #sleep 1;
# $session->output->print("...see?\n");
# }
# );
# return;
# TODO: refactor the following loop, find all instances of "chunked" and "empty" in codebase, etc..
for my $handler (@{$session->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 {
# Stop if the contentHandler is going to stream the response body
return if $session->response->streaming;
# We decide what to do next depending on what the contentHandler returned
# "chunked" or "empty" means it took care of its own output needs
if (defined $output && ( $output eq "chunked" || $output eq "empty" )) {
#warn "chunked and empty no longer stream, use session->response->stream() instead";
return;
}
else {
$gotMatch = 1;
if ($output ne Apache2::Const::DECLINED) {
return $output;
}
# non-empty output should be used as the response body
elsif (defined $output && $output ne "") {
# Auto-set the headers
$session->http->sendHeader;
# Use contentHandler's return value as the output
$session->output->print($output);
return;
}
# Keep processing for success codes
elsif ($session->http->getStatus < 200 || $session->http->getStatus > 299) {
$session->http->sendHeader;
return;
}
}
}
return Apache2::Const::DECLINED if ($gotMatch);
# can't handle the url due to error or misconfiguration
$request->push_handlers(PerlResponseHandler => sub {
print "This server is unable to handle the url '".$request->uri."' that you requested. ".$error;
return Apache2::Const::OK;
} );
$request->push_handlers(PerlTransHandler => sub { return Apache2::Const::OK });
return Apache2::Const::DECLINED;
}
return;
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;

13
lib/WebGUI/AdSpace.pm
View file

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

13
lib/WebGUI/AdSpace/Ad.pm
View file

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

8
lib/WebGUI/Asset.pm
View file

@ -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;

2
lib/WebGUI/Asset/Template.pm
View file

@ -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 );
}

1
lib/WebGUI/Asset/Wobject/Dashboard.pm
View file

@ -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) {

3
lib/WebGUI/Asset/Wobject/HttpProxy.pm
View file

@ -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";

5
lib/WebGUI/Asset/Wobject/HttpProxy/Parse.pm
View file

@ -50,11 +50,6 @@ my %tag_attr = (
"script src" => 1
);
sub DESTROY {
my $self = shift;
$self = undef;
}
=head2 new ( $class, $session)
Constructor for parser.

7
lib/WebGUI/Asset/Wobject/Layout.pm
View file

@ -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 {

12
lib/WebGUI/Asset/Wobject/ProjectManager.pm
View file

@ -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;

6
lib/WebGUI/Asset/Wobject/TimeTracking.pm
View file

@ -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]);

4
lib/WebGUI/AssetExportHtml.pm
View file

@ -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);

29
lib/WebGUI/Content/Asset.pm
View file

@ -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);

1
lib/WebGUI/DatabaseLink.pm
View file

@ -213,7 +213,6 @@ sub disconnect {
if (defined $self->{_dbh}) {
$self->{_dbh}->disconnect() unless ($self->getId eq "0");
}
undef $self;
}
#-------------------------------------------------------------------

53
lib/WebGUI/Exception.pm
View file

@ -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',
},
);

25
lib/WebGUI/FormValidator.pm
View file

@ -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;
}

16
lib/WebGUI/Group.pm
View file

@ -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 ] )

14
lib/WebGUI/HTMLForm.pm
View file

@ -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 )

13
lib/WebGUI/Inbox.pm
View file

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

13
lib/WebGUI/Inbox/Message.pm
View file

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

2
lib/WebGUI/LDAPLink.pm
View file

@ -121,10 +121,10 @@ sub connectToLDAP {
}
#-------------------------------------------------------------------
sub DESTROY {
my $self = shift;
$self->unbind;
undef $self;
}
#-------------------------------------------------------------------

7
lib/WebGUI/Macro/AssetProxy.pm
View file

@ -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 '';

4
lib/WebGUI/Macro/FilePump.pm
View file

@ -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) {

2
lib/WebGUI/Macro/Widget.pm
View file

@ -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
View 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
View 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
View 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
View 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;">&#87;&#104;&#121;&#32;&#119;&#111;&#117;&#108;&#100;&#32;&#121;&#111;&#117;&#32;&#116;&#121;&#112;&#101;&#32;&#105;&#110;&#32;&#116;&#104;&#105;&#115;&#32;&#85;&#82;&#76;&#63;&#32;&#82;&#101;&#97;&#108;&#108;&#121;&#46;&#32;&#87;&#104;&#97;&#116;&#32;&#119;&#101;&#114;&#101;&#32;&#121;&#111;&#117;&#32;&#101;&#120;&#112;&#101;&#99;&#116;&#105;&#110;&#103;&#32;&#116;&#111;&#32;&#115;&#101;&#101;&#32;&#104;&#101;&#114;&#101;&#63;&#32;&#89;&#111;&#117;&#32;&#114;&#101;&#97;&#108;&#108;&#121;&#32;&#110;&#101;&#101;&#100;&#32;&#116;&#111;&#32;&#103;&#101;&#116;&#32;&#97;&#32;&#108;&#105;&#102;&#101;&#46;&#32;&#65;&#114;&#101;&#32;&#121;&#111;&#117;&#32;&#115;&#116;&#105;&#108;&#108;&#32;&#104;&#101;&#114;&#101;&#63;&#32;&#83;&#101;&#114;&#105;&#111;&#117;&#115;&#108;&#121;&#44;&#32;&#121;&#111;&#117;&#32;&#110;&#101;&#101;&#100;&#32;&#116;&#111;&#32;&#103;&#111;&#32;&#100;&#111;&#32;&#115;&#111;&#109;&#101;&#116;&#104;&#105;&#110;&#103;&#32;&#101;&#108;&#115;&#101;&#46;&#32;&#73;&#32;&#116;&#104;&#105;&#110;&#107;&#32;&#121;&#111;&#117;&#114;&#32;&#98;&#111;&#115;&#115;&#32;&#105;&#115;&#32;&#99;&#97;&#108;&#108;&#105;&#110;&#103;&#46;</div></body></html>|;
return [ 200, [ 'Content-Type' => 'text/html' ], [ $snoop ] ];
} else {
return $self->app->($env);
}
}
1;

70
lib/WebGUI/Middleware/WGAccess.pm Normal file
View 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;

1
lib/WebGUI/Paths.pm
View file

@ -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) {

620
lib/WebGUI/SQL.pm
View file

@ -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);
}

376
lib/WebGUI/SQL/ResultSet.pm
View file

@ -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;

13
lib/WebGUI/Search/Index.pm
View file

@ -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

91
lib/WebGUI/Session.pm
View file

@ -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');
}
#-------------------------------------------------------------------

20
lib/WebGUI/Session/DateTime.pm
View file

@ -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;
}
#-------------------------------------------------------------------

49
lib/WebGUI/Session/Env.pm
View file

@ -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';
}

314
lib/WebGUI/Session/ErrorHandler.pm
View file

@ -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;

7
lib/WebGUI/Session/Form.pm
View file

@ -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};
}

112
lib/WebGUI/Session/Http.pm
View file

@ -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,
};
}

19
lib/WebGUI/Session/Icon.pm
View file

@ -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;
}

22
lib/WebGUI/Session/Id.pm
View file

@ -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;
}
#-------------------------------------------------------------------

104
lib/WebGUI/Session/Os.pm
View file

@ -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;

31
lib/WebGUI/Session/Output.pm
View file

@ -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;

20
lib/WebGUI/Session/Privilege.pm
View file

@ -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
View 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
View 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;

21
lib/WebGUI/Session/Scratch.pm
View file

@ -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;
}
#-------------------------------------------------------------------

22
lib/WebGUI/Session/Setting.pm
View file

@ -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;
}

19
lib/WebGUI/Session/Stow.pm
View file

@ -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;
}

19
lib/WebGUI/Session/Style.pm
View file

@ -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;
}
#-------------------------------------------------------------------

41
lib/WebGUI/Session/Url.pm
View file

@ -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;
}
#-------------------------------------------------------------------

18
lib/WebGUI/Session/Var.pm
View file

@ -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);
}

1
lib/WebGUI/Shop/Address.pm
View file

@ -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;
}

1
lib/WebGUI/Shop/AddressBook.pm
View file

@ -91,7 +91,6 @@ sub delete {
$address->delete;
}
$self->session->db->write("delete from addressBook where addressBookId=?",[$self->getId]);
undef $self;
return undef;
}

1
lib/WebGUI/Shop/Transaction.pm
View file

@ -182,7 +182,6 @@ sub delete {
$item->delete;
}
$self->session->db->write("delete from transaction where transactionId=?",[$self->getId]);
undef $self;
return undef;
}

1
lib/WebGUI/Shop/TransactionItem.pm
View file

@ -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;
}

4
lib/WebGUI/Storage.pm
View file

@ -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'}

119
lib/WebGUI/URL/Content.pm
View file

@ -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;

59
lib/WebGUI/URL/PassThru.pm
View file

@ -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;

61
lib/WebGUI/URL/Snoop.pm
View file

@ -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;">&#87;&#104;&#121;&#32;&#119;&#111;&#117;&#108;&#100;&#32;&#121;&#111;&#117;&#32;&#116;&#121;&#112;&#101;&#32;&#105;&#110;&#32;&#116;&#104;&#105;&#115;&#32;&#85;&#82;&#76;&#63;&#32;&#82;&#101;&#97;&#108;&#108;&#121;&#46;&#32;&#87;&#104;&#97;&#116;&#32;&#119;&#101;&#114;&#101;&#32;&#121;&#111;&#117;&#32;&#101;&#120;&#112;&#101;&#99;&#116;&#105;&#110;&#103;&#32;&#116;&#111;&#32;&#115;&#101;&#101;&#32;&#104;&#101;&#114;&#101;&#63;&#32;&#89;&#111;&#117;&#32;&#114;&#101;&#97;&#108;&#108;&#121;&#32;&#110;&#101;&#101;&#100;&#32;&#116;&#111;&#32;&#103;&#101;&#116;&#32;&#97;&#32;&#108;&#105;&#102;&#101;&#46;&#32;&#65;&#114;&#101;&#32;&#121;&#111;&#117;&#32;&#115;&#116;&#105;&#108;&#108;&#32;&#104;&#101;&#114;&#101;&#63;&#32;&#83;&#101;&#114;&#105;&#111;&#117;&#115;&#108;&#121;&#44;&#32;&#121;&#111;&#117;&#32;&#110;&#101;&#101;&#100;&#32;&#116;&#111;&#32;&#103;&#111;&#32;&#100;&#111;&#32;&#115;&#111;&#109;&#101;&#116;&#104;&#105;&#110;&#103;&#32;&#101;&#108;&#115;&#101;&#46;&#32;&#73;&#32;&#116;&#104;&#105;&#110;&#107;&#32;&#121;&#111;&#117;&#114;&#32;&#98;&#111;&#115;&#115;&#32;&#105;&#115;&#32;&#99;&#97;&#108;&#108;&#105;&#110;&#103;&#46;</div></body></html>|);
return Apache2::Const::OK;
} );
$request->push_handlers(PerlTransHandler => sub { return Apache2::Const::OK });
return Apache2::Const::OK;
}
1;

54
lib/WebGUI/URL/Unauthorized.pm
View file

@ -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;

107
lib/WebGUI/URL/Uploads.pm
View file

@ -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;

55
lib/WebGUI/URL/_url.skeleton
View file

@ -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

15
lib/WebGUI/Workflow.pm
View file

@ -163,21 +163,6 @@ sub demoteActivity {
}
}
#-------------------------------------------------------------------
=head2 DESTROY ( )
Deconstructor.
=cut
sub DESTROY {
my $self = shift;
undef $self;
}
#-------------------------------------------------------------------
=head2 get ( name )

15
lib/WebGUI/Workflow/Activity.pm
View file

@ -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 )

3
lib/WebGUI/Workflow/Activity/SendWebguiStats.pm
View file

@ -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"),

15
lib/WebGUI/Workflow/Cron.pm
View file

@ -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 )

2
lib/WebGUI/Workflow/Instance.pm
View file

@ -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;
}

13
lib/WebGUI/Workflow/Spectre.pm
View file

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

2
sbin/fileImport.pl
View file

@ -202,7 +202,7 @@ sub setPrivilege {
my $path = shift;
print "\t\tSetting filesystem privilege. " unless ($quiet);
if ($session->os->get("type") eq "Linuxish") {
if ($^O ne 'MSWin32') {
unless (system("chown -R ".$webUser." ". $path)) {
print "Privileges set.\n" unless ($quiet);
}

8
sbin/testEnvironment.pl
View file

@ -26,7 +26,7 @@ use Pod::Usage;
use Cwd ();
my ($os, $prereq, $dbi, $dbDrivers, $simpleReport, $help, $noprompt);
my ($prereq, $dbi, $dbDrivers, $simpleReport, $help, $noprompt);
GetOptions(
'noprompt' => \$noprompt,
@ -108,7 +108,10 @@ checkModule("Finance::Quote", 1.15 );
checkModule("POE", 1.005 );
checkModule("POE::Component::IKC::Server", 0.2001 );
checkModule("POE::Component::Client::HTTP", 0.88 );
checkModule("Apache2::Request", 2.08 );
checkModule("Plack::Request");
checkModule("Plack::Response");
checkModule("Plack::Middleware::Status");
checkModule("Plack::Middleware::Debug");
checkModule("URI::Escape", "3.29" );
checkModule("POSIX" );
checkModule("List::Util" );
@ -139,6 +142,7 @@ checkModule("JavaScript::Minifier::XS", "0.05" );
checkModule("Readonly", "1.03" );
checkModule("Moose", "0.93" );
checkModule("MooseX::Storage", "0.23" );
checkModule("MooseX::NonMoose", '0.07' );
checkModule("MooseX::Storage::Format::JSON","0.27" );
checkModule("namespace::autoclean", "0.09" );
checkModule("Business::PayPal::API", "0.62" );

2
t/Asset/Template.t
View file

@ -49,7 +49,7 @@ ok($output =~ m/true/, "process() - conditionals");
ok($output =~ m/\b(?:XY){5}\b/, "process() - loops");
# See if template listens the Accept header
$session->request->headers_in->{Accept} = 'application/json';
$session->request->header('Accept' => 'application/json');
my $json = $template->process(\%var);
my $andNowItsAPerlHashRef = eval { from_json( $json ) };

34
t/Auth.t
View file

@ -38,52 +38,40 @@ plan tests => 3; # Increment this number for each test you create
#----------------------------------------------------------------------------
# Test createAccountSave and returnUrl together
# Set up request
$oldRequest = $session->request;
$request = WebGUI::PseudoRequest->new;
$request->setup_param({
my $createAccountSession = WebGUI::Test->newSession(0, {
returnUrl => 'REDIRECT_URL',
});
$session->{_request} = $request;
$auth = WebGUI::Auth->new( $session, $AUTH_METHOD );
my $username = $session->id->generate;
$auth = WebGUI::Auth->new( $createAccountSession, $AUTH_METHOD );
my $username = $createAccountSession->id->generate;
push @cleanupUsernames, $username;
$output = $auth->createAccountSave( $username, { }, "PASSWORD" );
$output = $auth->createAccountSave( $username, { }, "PASSWORD" );
is(
$session->http->getRedirectLocation, 'REDIRECT_URL',
$createAccountSession->http->getRedirectLocation, 'REDIRECT_URL',
"returnUrl field is used to set redirect after createAccountSave",
);
# Session Cleanup
$session->{_request} = $oldRequest;
#----------------------------------------------------------------------------
# Test login and returnUrl together
# Set up request
$oldRequest = $session->request;
$request = WebGUI::PseudoRequest->new;
$request->setup_param({
my $loginSession = WebGUI::Test->newSession(0, {
returnUrl => 'REDIRECT_LOGIN_URL',
});
$session->{_request} = $request;
$auth = WebGUI::Auth->new( $session, $AUTH_METHOD, 3 );
my $username = $session->id->generate;
$auth = WebGUI::Auth->new( $loginSession, $AUTH_METHOD, 3 );
my $username = $loginSession->id->generate;
push @cleanupUsernames, $username;
$session->setting->set('showMessageOnLogin', 0);
$output = $auth->login;
$output = $auth->login;
is(
$session->http->getRedirectLocation, 'REDIRECT_LOGIN_URL',
$loginSession->http->getRedirectLocation, 'REDIRECT_LOGIN_URL',
"returnUrl field is used to set redirect after login",
);
is $output, undef, 'login returns undef when showMessageOnLogin is false';
# Session Cleanup
$session->{_request} = $oldRequest;
#----------------------------------------------------------------------------
# Cleanup
END {

85
t/Exception/app.t Normal file
View file

@ -0,0 +1,85 @@
# Test what happens when the WebGUI PSGI app throws exceptions
use strict;
use FindBin;
use lib "$FindBin::Bin/../../lib";
use WebGUI;
use Plack::Test;
use Plack::Builder;
use HTTP::Request::Common;
use Test::More tests => 9;
use HTTP::Exception;
my $wg = WebGUI->new;
my $regular_app = builder {
enable '+WebGUI::Middleware::Session', config => $wg->config;
$wg;
};
my $generic_dead_app = builder {
enable '+WebGUI::Middleware::Session', config => $wg->config;
# Pretend that WebGUI dies during request handling
sub { die 'WebGUI died' }
};
my $specific_dead_app = builder {
enable '+WebGUI::Middleware::Session', config => $wg->config;
# Pretend that WebGUI throws a '501 - Not Implemented' HTTP error
sub { HTTP::Exception::501->throw }
};
my $fatal_app = builder {
enable '+WebGUI::Middleware::Session', config => $wg->config;
# Pretend that WebGUI calls $session->log->fatal during request handling
sub {
my $env = shift;
$env->{'webgui.session'}->log->fatal('Fatally yours');
}
};
test_psgi $regular_app, sub {
my $cb = shift;
my $res = $cb->( GET "/" );
like $res->content, qr/My Company/;
};
# N.B. The die() is caught thanks to WebGUI::Middleware::HTTPExceptions,
# but generates a warning to STDOUT - should perhaps be silenced?
test_psgi $generic_dead_app, sub {
my $cb = shift;
my $res = $cb->( GET "/" );
is $res->code, 500;
is $res->content, 'Internal Server Error';
};
test_psgi $specific_dead_app, sub {
my $cb = shift;
my $res = $cb->( GET "/" );
is $res->code, 501;
is $res->content, 'Not Implemented'; # how apt
};
test_psgi $fatal_app, sub {
my $cb = shift;
my $res = $cb->( GET "/" );
is $res->code, 500;
# WebGUI doesn't know who you are, so it displays the generic error page
like $res->content, qr/Problem With Request/;
};
test_psgi $fatal_app, sub {
my $cb = shift;
local *WebGUI::Session::ErrorHandler::canShowDebug = sub {1};
my $res = $cb->( GET "/" );
is $res->code, 500;
# We canShowDebug, so WebGUI gives us more info
like $res->content, qr/Fatally yours/;
};

23
t/PSGI/default-site.t Normal file
View file

@ -0,0 +1,23 @@
use strict;
use warnings;
use Test::More tests => 4;
use Plack::Test;
use Plack::Util;
use HTTP::Request::Common;
use WebGUI::Paths;
my $app = Plack::Util::load_psgi( WebGUI::Paths->defaultPSGI );
test_psgi $app, sub {
my $cb = shift;
my $res = $cb->( GET "/" );
is $res->code, 200;
like $res->content, qr/My Company/;
$res = $cb->( GET "/?op=editSettings" );
is $res->code, 401;
like $res->content, qr/Administrative Function/;
};

52
t/Session/Os.t
View file

@ -1,52 +0,0 @@
#-------------------------------------------------------------------
# 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
#-------------------------------------------------------------------
use FindBin;
use strict;
use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::Session;
use WebGUI::Session::Os;
my @testSets = (
{
os => 'Win',
type => 'Windowsish',
},
{
os => 'win32',
type => 'Windowsish',
},
{
os => 'MSWin32',
type => 'Windowsish',
},
{
os => 'Amiga OS',
type => 'Linuxish',
},
);
use Test::More;
my $numTests = 2 * scalar @testSets;
plan tests => $numTests;
my $session = WebGUI::Test->session;
foreach my $test (@testSets) {
local $^O = $test->{os};
my $os = WebGUI::Session::Os->new($session);
is($os->get('name'), $test->{os}, "$test->{os}: name set");
is($os->get('type'), $test->{type}, "$test->{os}: type set");
}

70
t/Session/Url.t
View file

@ -13,7 +13,6 @@ use strict;
use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::PseudoRequest;
use WebGUI::Session;
use WebGUI::Asset;
@ -51,13 +50,10 @@ my @getRefererUrlTests = (
);
use Test::More;
use Test::MockObject::Extends;
plan tests => 81 + scalar(@getRefererUrlTests);
plan tests => 79 + scalar(@getRefererUrlTests);
my $session = WebGUI::Test->session;
my $pseudoRequest = WebGUI::PseudoRequest->new();
$session->{_request} = $pseudoRequest;
my $request = $session->request;
#disable caching
my $preventProxyCache = $session->setting->get('preventProxyCache');
@ -140,17 +136,14 @@ $session->url->setSiteURL('http://webgui.org');
is( $session->url->getSiteURL, 'http://webgui.org', 'override config setting with setSiteURL');
##Create a fake environment hash so we can muck with it.
my %mockEnv = %ENV;
my $env = $session->env;
$env = Test::MockObject::Extends->new($env);
$env->mock('get', sub { return $mockEnv{$_[1]} } );
my $env = $session->request->env;
$mockEnv{HTTPS} = "on";
$env->{'psgi.url_scheme'} = "https";
$session->url->setSiteURL(undef);
is( $session->url->getSiteURL, 'https://'.$sitename, 'getSiteURL from config as http_host with SSL');
$mockEnv{HTTPS} = "";
$mockEnv{HTTP_HOST} = "devsite.com";
$env->{'psgi.url_scheme'} = "http";
$env->{HTTP_HOST} = "devsite.com";
$session->url->setSiteURL(undef);
is( $session->url->getSiteURL, 'http://'.$sitename, 'getSiteURL where requested host is not a configured site');
@ -194,26 +187,29 @@ is( $session->url->makeCompliant($url), $url2, 'language specific URL compliance
#
#######################################
my $originalRequest = $session->request; ##Save the original request object
my $setUri = sub {
$request->env->{PATH_INFO} = $_[0];
};
$session->{_request} = undef;
is($session->url->getRequestedUrl, undef, 'getRequestedUrl returns undef unless it has a request object');
$session->{_request} = $originalRequest;
$pseudoRequest->uri('empty');
is($session->request->uri, 'empty', 'Validate Mock Object operation');
$session->{_request} = $request;
$pseudoRequest->uri('full');
is($session->request->uri, 'full', 'Validate Mock Object operation #2');
$setUri->('empty');
is($session->request->uri, 'http://devsite.com/empty', 'Validate Mock Object operation');
$pseudoRequest->uri('/path1/file1');
$setUri->('full');
is($session->request->uri, 'http://devsite.com/full', 'Validate Mock Object operation #2');
$setUri->('/path1/file1');
is($session->url->getRequestedUrl, 'path1/file1', 'getRequestedUrl, fetch');
$pseudoRequest->uri('/path2/file2');
$setUri->('/path2/file2');
is($session->url->getRequestedUrl, 'path1/file1', 'getRequestedUrl, check cache of previous result');
$session->url->{_requestedUrl} = undef; ##Manually clear cached value
$pseudoRequest->uri('/path2/file2?param1=one;param2=two');
$setUri->('/path2/file2?param1=one;param2=two');
is($session->url->getRequestedUrl, 'path2/file2', 'getRequestedUrl, does not return params');
#######################################
@ -226,7 +222,7 @@ my $sessionAsset = $session->asset;
$session->asset(undef);
$session->url->{_requestedUrl} = undef; ##Manually clear cached value
$pseudoRequest->uri('/path1/">file1');
$setUri->('/path1/">file1');
is($session->url->page, '/path1/%22%3Efile1', 'page with no args returns getRequestedUrl through gateway, escaping the requested URL for safety');
is($session->url->page('op=viewHelpTOC;topic=Article'), '/path1/%22%3Efile1?op=viewHelpTOC;topic=Article', 'page: pairs are appended');
@ -256,12 +252,12 @@ $session->asset($sessionAsset);
#
#######################################
$mockEnv{'HTTP_REFERER'} = 'test';
$env->{'HTTP_REFERER'} = 'test';
is($session->env->get('HTTP_REFERER'), 'test', 'testing overridden ENV');
foreach my $test (@getRefererUrlTests) {
$mockEnv{HTTP_REFERER} = $test->{input};
$env->{HTTP_REFERER} = $test->{input};
is($session->url->getRefererUrl, $test->{output}, $test->{comment});
}
@ -321,14 +317,10 @@ is($session->url->extras('/dir1/foo.html'), join('', $cdnCfg->{extrasCdn}, 'dir1
is($session->url->extras('tinymce'), join('', $extras, 'tinymce'),
'extras exclusion from CDN');
# Note: env is already mocked above.
$mockEnv{HTTPS} = 'on';
$env->{'psgi.url_scheme'} = "https";
is($session->url->extras('/dir1/foo.html'), join('', $cdnCfg->{extrasSsl}, 'dir1/foo.html'),
'extras using extrasSsl with HTTPS');
$mockEnv{HTTPS} = undef;
$mockEnv{SSLPROXY} = 1;
is($session->url->extras('/dir1/foo.html'), join('', $cdnCfg->{extrasSsl}, 'dir1/foo.html'),
'extras using extrasSsl with SSLPROXY');
delete $mockEnv{SSLPROXY};
$env->{'psgi.url_scheme'} = "http";
$session->config->set('extrasURL', $origExtras);
@ -376,7 +368,7 @@ is($session->url->urlize('home/././here'), 'home/here', '... removes
$sessionAsset = $session->asset;
$session->{_asset} = undef;
$session->url->{_requestedUrl} = undef; ##Manually clear cached value
$pseudoRequest->uri('/goBackToTheSite');
$setUri->('/goBackToTheSite');
is($session->url->getBackToSiteURL, '/goBackToTheSite', 'getBackToSiteURL: when session asset is undefined, the method falls back to using page');
@ -449,19 +441,12 @@ my $origSSLEnabled = $session->config->get('sslEnabled');
##Test all the false cases, first
$session->config->set('sslEnabled', 0);
$mockEnv{HTTPS} = 'not on';
$mockEnv{SSLPROXY} = 0;
$env->{'psgi.url_scheme'} = "http";
ok( ! $session->url->forceSecureConnection(), 'sslEnabled must be 1 to force SSL');
$session->config->set('sslEnabled', 1);
$mockEnv{HTTPS} = 'on';
$mockEnv{SSLPROXY} = 0;
$env->{'psgi.url_scheme'} = "https";
ok( ! $session->url->forceSecureConnection(), 'HTTPS must not be "on" to force SSL');
$session->config->set('sslEnabled', 1);
$mockEnv{HTTPS} = 'not on';
$mockEnv{SSLPROXY} = 1;
ok( ! $session->url->forceSecureConnection(), 'SSLPROXY must not be true to force SSL');
ok( ! $session->url->forceSecureConnection('/test/url'), 'all conditions must be met, even if a URL is directly passed in');
##Validate the HTTP object state before we start
@ -469,8 +454,7 @@ $session->http->setStatus('200', 'OK');
is($session->http->getStatus, 200, 'http status is okay, 200');
is($session->http->getRedirectLocation, undef, 'redirect location is empty');
$mockEnv{HTTPS} = 'not on';
$mockEnv{SSLPROXY} = 0;
$env->{'psgi.url_scheme'} = "http";
my $secureUrl = $session->url->getSiteURL . '/foo/bar/baz/buz';
$secureUrl =~ s/http:/https:/;

58
t/lib/WebGUI/Test.pm
View file

@ -136,7 +136,7 @@ END {
#----------------------------------------------------------------------------
=head2 newSession ( $noCleanup )
=head2 newSession ( $noCleanup, [ $request ] )
Builds a WebGUI session object for testing.
@ -144,22 +144,60 @@ Builds a WebGUI session object for testing.
If true, the session won't be registered for automatic deletion.
=head3 $request
Either a HTTP::Request object to use for this session, or a hash ref of form parameters.
=cut
sub newSession {
shift
if eval { $_[0]->isa($CLASS) };
my $noCleanup = shift;
my $pseudoRequest = WebGUI::PseudoRequest->new;
my $request = shift;
require WebGUI::Session;
my $session = WebGUI::Session->open( $CLASS->config );
$session->{_request} = $pseudoRequest;
my $session = WebGUI::Session->open( $CLASS->config, newEnv( $request ) );
if ( ! $noCleanup ) {
$CLASS->addToCleanup($session);
}
return $session;
}
sub newEnv {
shift
if eval { $_[0]->isa($CLASS) };
my $form = shift;
require HTTP::Message::PSGI;
require HTTP::Request::Common;
my $config = $CLASS->config;
my $request;
if ( try { $form->isa('HTTP::Request') } ) {
$request = $form;
}
else {
my $url = 'http://' . $config->get('sitename')->[0];
$request = $form
? HTTP::Request::Common::POST( $url, [ %$form ] )
: HTTP::Request::Common::GET( $url )
;
}
return $request->to_psgi;
}
sub clientTest (&) {
my $client = shift;
local $ENV{WEBGUI_CONFIG} = $CLASS->file;
my $test_psgi = Plack::Util::load_psgi(
$CLASS->config->get('psgiFile')
|| WebGUI::Paths->defaultPSGI,
);
Plack::Test::test_psgi(
app => $test_psgi,
client => $client,
);
}
#----------------------------------------------------------------------------
=head2 interceptLogging
@ -265,6 +303,9 @@ below.
=cut
# I think that getPage should be entirely replaced with calles to Plack::Test::test_psgi
# - testing with the callback is better and it means we can run on any backend
sub getPage {
my $class = shift;
my $actor = shift; # The actor to work on
@ -288,9 +329,10 @@ sub getPage {
# Create a new request object
my $oldRequest = $session->request;
my $request = WebGUI::PseudoRequest->new;
$request->setup_param($optionsRef->{formParams});
my $request = WebGUI::Session::Request->new(newEnv($optionsRef->{formParams}));
# $request->setup_param($optionsRef->{formParams});
local $session->{_request} = $request;
local $session->{_response} = $request->new_response( 200 );
local $session->output->{_handle};
# Fill the buffer
@ -315,7 +357,7 @@ sub getPage {
$session->user({ user => $oldUser });
# Return the page's output
return $request->get_output;
return join '', @{$session->response->body};
}
#----------------------------------------------------------------------------
@ -516,7 +558,7 @@ Example call:
( $sql, @params ) = @$sql;
}
return sub {
$db->write( $sql, {}, @params );
$db->do( $sql, {}, @params );
}
},
);

57
var/site.psgi Normal file
View file

@ -0,0 +1,57 @@
use strict;
use Plack::Builder;
use Plack::App::File;
use WebGUI;
builder {
my $wg = WebGUI->new( site => $ENV{WEBGUI_CONFIG} );
my $config = $wg->config;
enable 'Log4perl', category => $config->getFilename, conf => WebGUI::Paths->logConfig;
enable 'SimpleContentFilter', filter => sub {
if ( utf8::is_utf8($_) ) {
utf8::encode($_);
}
};
# Reproduce URL handler functionality with middleware
enable '+WebGUI::Middleware::Snoop';
enable 'Status', path => qr{^/uploads/dictionaries}, status => 401;
# For PassThru, use Plack::Builder::mount
# Extras fallback (you should be using something else to serve static files in production)
my ( $extrasURL, $extrasPath ) = ( $config->get('extrasURL'), $config->get('extrasPath') );
enable 'Static', root => "$extrasPath/", path => sub {s{^\Q$extrasURL/}{}};
# Open/close the WebGUI::Session at the outer-most onion layer
enable '+WebGUI::Middleware::Session', config => $config;
enable '+WebGUI::Middleware::HTTPExceptions';
enable_if { ! $_[0]->{'webgui.debug'} } 'ErrorDocument', 500 => $config->get('maintenancePage');
enable_if { $_[0]->{'webgui.debug'} } 'StackTrace';
enable_if { $_[0]->{'webgui.debug'} } 'Debug', panels => [
'Environment',
'Response',
'Timer',
'Memory',
'Session',
'PerlConfig',
[ 'MySQLTrace', skip_packages => qr/\AWebGUI::SQL(?:\z|::)/ ],
'Response',
'Logger',
];
enable_if { $_[0]->{'webgui.debug'} } '+WebGUI::Middleware::Debug::Performance';
# This one uses the Session object, so it comes after WebGUI::Middleware::Session
mount $config->get('uploadsURL') => builder {
enable '+WebGUI::Middleware::WGAccess';
Plack::App::File->new(root => $config->get('uploadsPath'));
};
# Return the app
mount '/' => $wg->to_app;
};