diff --git a/README b/README new file mode 100644 index 000000000..4ab9f2f19 --- /dev/null +++ b/README @@ -0,0 +1,33 @@ +This is the PSGI branch of WebGUI8 + +To try this out: + + 1) Run testEnvironment.pl to install Plack + 2) $ cd + 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) + diff --git a/TODO b/TODO new file mode 100644 index 000000000..e771de9ba --- /dev/null +++ b/TODO @@ -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' \ No newline at end of file diff --git a/WebGUI-Session-Plack.pm b/WebGUI-Session-Plack.pm new file mode 100644 index 000000000..411f6775c --- /dev/null +++ b/WebGUI-Session-Plack.pm @@ -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; diff --git a/app.psgi b/app.psgi new file mode 100644 index 000000000..bace19496 --- /dev/null +++ b/app.psgi @@ -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; +}; + diff --git a/benchmark.pl b/benchmark.pl new file mode 100755 index 000000000..fa71b1dc4 --- /dev/null +++ b/benchmark.pl @@ -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; +}; \ No newline at end of file diff --git a/eg/README b/eg/README new file mode 100644 index 000000000..8b195c8f0 --- /dev/null +++ b/eg/README @@ -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/"; \ No newline at end of file diff --git a/eg/apache.conf b/eg/apache.conf new file mode 100644 index 000000000..71ea48165 --- /dev/null +++ b/eg/apache.conf @@ -0,0 +1,27 @@ + + PerlOptions +Parent + PerlSwitches -I/data/WebGUI/lib + + # CGI + #AddHandler cgi-script cgi + #ScriptAlias / /data/WebGUI/etc/dev.localhost.localdomain.cgi/ + # + # Options +ExecCGI + # + + # 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 + # + # SetHandler psgi + # PSGIApp /data/WebGUI/etc/dev.localhost.localdomain.psgi + # + + diff --git a/eg/dev.localhost.localdomain.cgi b/eg/dev.localhost.localdomain.cgi new file mode 100755 index 000000000..71eee8fab --- /dev/null +++ b/eg/dev.localhost.localdomain.cgi @@ -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); \ No newline at end of file diff --git a/eg/dev.localhost.localdomain.fcgi b/eg/dev.localhost.localdomain.fcgi new file mode 100755 index 000000000..ca633fef5 --- /dev/null +++ b/eg/dev.localhost.localdomain.fcgi @@ -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); diff --git a/eg/dev.localhost.localdomain.perlbal b/eg/dev.localhost.localdomain.perlbal new file mode 100644 index 000000000..98b85382e --- /dev/null +++ b/eg/dev.localhost.localdomain.perlbal @@ -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 \ No newline at end of file diff --git a/eg/urlmap.psgi b/eg/urlmap.psgi new file mode 100644 index 000000000..1d402c65e --- /dev/null +++ b/eg/urlmap.psgi @@ -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' ], [ <WebGUI + URLMap

+ +END_HTML +}; diff --git a/lib/Plack/Middleware/Debug/Logger.pm b/lib/Plack/Middleware/Debug/Logger.pm new file mode 100644 index 000000000..4cd3efe2e --- /dev/null +++ b/lib/Plack/Middleware/Debug/Logger.pm @@ -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('
' . $self->render_list_pairs( $log_output ) . '
'); + } + }; +} + +1; + diff --git a/lib/Plack/Middleware/Debug/MySQLTrace.pm b/lib/Plack/Middleware/Debug/MySQLTrace.pm new file mode 100644 index 000000000..3e936b4de --- /dev/null +++ b/lib/Plack/Middleware/Debug/MySQLTrace.pm @@ -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('
' . $self->render_list_pairs(\@output) . '
'); + } + }; +} + +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 + +=cut diff --git a/lib/Spectre/Cron.pm b/lib/Spectre/Cron.pm index d13f2b876..c101a9e8f 100644 --- a/lib/Spectre/Cron.pm +++ b/lib/Spectre/Cron.pm @@ -49,7 +49,6 @@ Gracefully shuts down the scheduler. sub _stop { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->debug("Stopping the scheduler."); - undef $self; } #------------------------------------------------------------------- diff --git a/lib/Spectre/Workflow.pm b/lib/Spectre/Workflow.pm index f79e0144e..69a613b2a 100644 --- a/lib/Spectre/Workflow.pm +++ b/lib/Spectre/Workflow.pm @@ -50,7 +50,6 @@ Gracefully shuts down the workflow manager. sub _stop { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->debug("Stopping workflow manager."); - undef $self; } #------------------------------------------------------------------- diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 722630669..548f17d8b 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -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; - diff --git a/lib/WebGUI/AdSpace.pm b/lib/WebGUI/AdSpace.pm index 259f58b73..4b670b70b 100644 --- a/lib/WebGUI/AdSpace.pm +++ b/lib/WebGUI/AdSpace.pm @@ -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. diff --git a/lib/WebGUI/AdSpace/Ad.pm b/lib/WebGUI/AdSpace/Ad.pm index ca44a95f2..23d147200 100644 --- a/lib/WebGUI/AdSpace/Ad.pm +++ b/lib/WebGUI/AdSpace/Ad.pm @@ -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. diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 1443bfaa3..e0cf0735e 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -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; diff --git a/lib/WebGUI/Asset/Template.pm b/lib/WebGUI/Asset/Template.pm index c4c9a6aec..a58f5b8aa 100644 --- a/lib/WebGUI/Asset/Template.pm +++ b/lib/WebGUI/Asset/Template.pm @@ -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 ); } diff --git a/lib/WebGUI/Asset/Wobject/Dashboard.pm b/lib/WebGUI/Asset/Wobject/Dashboard.pm index 951bd6cce..02f6f2894 100644 --- a/lib/WebGUI/Asset/Wobject/Dashboard.pm +++ b/lib/WebGUI/Asset/Wobject/Dashboard.pm @@ -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) { diff --git a/lib/WebGUI/Asset/Wobject/HttpProxy.pm b/lib/WebGUI/Asset/Wobject/HttpProxy.pm index ab2a6e42a..49e293922 100644 --- a/lib/WebGUI/Asset/Wobject/HttpProxy.pm +++ b/lib/WebGUI/Asset/Wobject/HttpProxy.pm @@ -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} =~ / 1 ); -sub DESTROY { - my $self = shift; - $self = undef; -} - =head2 new ( $class, $session) Constructor for parser. diff --git a/lib/WebGUI/Asset/Wobject/Layout.pm b/lib/WebGUI/Asset/Wobject/Layout.pm index 5e5c0ea6a..d55e9af05 100644 --- a/lib/WebGUI/Asset/Wobject/Layout.pm +++ b/lib/WebGUI/Asset/Wobject/Layout.pm @@ -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 { diff --git a/lib/WebGUI/Asset/Wobject/ProjectManager.pm b/lib/WebGUI/Asset/Wobject/ProjectManager.pm index d048b73a3..5b3209ac9 100644 --- a/lib/WebGUI/Asset/Wobject/ProjectManager.pm +++ b/lib/WebGUI/Asset/Wobject/ProjectManager.pm @@ -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; diff --git a/lib/WebGUI/Asset/Wobject/TimeTracking.pm b/lib/WebGUI/Asset/Wobject/TimeTracking.pm index faf8915d0..8882b452c 100644 --- a/lib/WebGUI/Asset/Wobject/TimeTracking.pm +++ b/lib/WebGUI/Asset/Wobject/TimeTracking.pm @@ -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|
$_[1]| 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|$_[0]| if($_[0]); diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index af1d4f6f7..de0bf51f4 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -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); diff --git a/lib/WebGUI/Content/Asset.pm b/lib/WebGUI/Content/Asset.pm index 2537dcdec..616000ea6 100644 --- a/lib/WebGUI/Content/Asset.pm +++ b/lib/WebGUI/Content/Asset.pm @@ -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); diff --git a/lib/WebGUI/DatabaseLink.pm b/lib/WebGUI/DatabaseLink.pm index 8dffa550f..a045191a5 100644 --- a/lib/WebGUI/DatabaseLink.pm +++ b/lib/WebGUI/DatabaseLink.pm @@ -213,7 +213,6 @@ sub disconnect { if (defined $self->{_dbh}) { $self->{_dbh}->disconnect() unless ($self->getId eq "0"); } - undef $self; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Exception.pm b/lib/WebGUI/Exception.pm index f031a50ec..73dd2504c 100644 --- a/lib/WebGUI/Exception.pm +++ b/lib/WebGUI/Exception.pm @@ -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', + }, ); diff --git a/lib/WebGUI/FormValidator.pm b/lib/WebGUI/FormValidator.pm index 6c465c382..9df082177 100644 --- a/lib/WebGUI/FormValidator.pm +++ b/lib/WebGUI/FormValidator.pm @@ -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; } diff --git a/lib/WebGUI/Group.pm b/lib/WebGUI/Group.pm index bf2b062d0..fff230d5d 100644 --- a/lib/WebGUI/Group.pm +++ b/lib/WebGUI/Group.pm @@ -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 ] ) diff --git a/lib/WebGUI/HTMLForm.pm b/lib/WebGUI/HTMLForm.pm index a02295a63..b304bd2ce 100644 --- a/lib/WebGUI/HTMLForm.pm +++ b/lib/WebGUI/HTMLForm.pm @@ -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 ) diff --git a/lib/WebGUI/Inbox.pm b/lib/WebGUI/Inbox.pm index 201ff5330..ad02afa12 100644 --- a/lib/WebGUI/Inbox.pm +++ b/lib/WebGUI/Inbox.pm @@ -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. diff --git a/lib/WebGUI/Inbox/Message.pm b/lib/WebGUI/Inbox/Message.pm index 642aed264..09fc40c4e 100644 --- a/lib/WebGUI/Inbox/Message.pm +++ b/lib/WebGUI/Inbox/Message.pm @@ -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. diff --git a/lib/WebGUI/LDAPLink.pm b/lib/WebGUI/LDAPLink.pm index 3b413dbb5..5c9f8daec 100644 --- a/lib/WebGUI/LDAPLink.pm +++ b/lib/WebGUI/LDAPLink.pm @@ -121,10 +121,10 @@ sub connectToLDAP { } #------------------------------------------------------------------- + sub DESTROY { my $self = shift; $self->unbind; - undef $self; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Macro/AssetProxy.pm b/lib/WebGUI/Macro/AssetProxy.pm index bcbe2c03b..169bfe5d2 100644 --- a/lib/WebGUI/Macro/AssetProxy.pm +++ b/lib/WebGUI/Macro/AssetProxy.pm @@ -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 ''; diff --git a/lib/WebGUI/Macro/FilePump.pm b/lib/WebGUI/Macro/FilePump.pm index 22f69e381..fb2427ee2 100644 --- a/lib/WebGUI/Macro/FilePump.pm +++ b/lib/WebGUI/Macro/FilePump.pm @@ -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) { diff --git a/lib/WebGUI/Macro/Widget.pm b/lib/WebGUI/Macro/Widget.pm index ab7e2faee..6c4bba62c 100644 --- a/lib/WebGUI/Macro/Widget.pm +++ b/lib/WebGUI/Macro/Widget.pm @@ -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; diff --git a/lib/WebGUI/Middleware/Debug/Performance.pm b/lib/WebGUI/Middleware/Debug/Performance.pm new file mode 100644 index 000000000..f8739a1f7 --- /dev/null +++ b/lib/WebGUI/Middleware/Debug/Performance.pm @@ -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'); + + + + + + + + + +% my $i; +% for my $event ( @{ $_[0]->{list} } ) { + + + + + +% } + +
TimeTypeItem
<%= $event->{time} %><%= $event->{type} %> +% if ($event->{message}) { + <%= $event->{message} %> +% } +% if ($event->{assetTitle}) { + View + Edit + <%= $event->{assetTitle} %> +% } +
+EOTMPL + +sub render_log { + my ($self, $events) = @_; + $self->render($log_template, { list => $events }); +} + +1; + diff --git a/lib/WebGUI/Middleware/HTTPExceptions.pm b/lib/WebGUI/Middleware/HTTPExceptions.pm new file mode 100644 index 000000000..132747452 --- /dev/null +++ b/lib/WebGUI/Middleware/HTTPExceptions.pm @@ -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 + +=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; \ No newline at end of file diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm new file mode 100644 index 000000000..4e9014d79 --- /dev/null +++ b/lib/WebGUI/Middleware/Session.pm @@ -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 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 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; diff --git a/lib/WebGUI/Middleware/Snoop.pm b/lib/WebGUI/Middleware/Snoop.pm new file mode 100644 index 000000000..ec88ae9ff --- /dev/null +++ b/lib/WebGUI/Middleware/Snoop.pm @@ -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, back when we still had URL handlers. + +L 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|Snoopy
Why would you type in this URL? Really. What were you expecting to see here? You really need to get a life. Are you still here? Seriously, you need to go do something else. I think your boss is calling.
|; + return [ 200, [ 'Content-Type' => 'text/html' ], [ $snoop ] ]; + } else { + return $self->app->($env); + } +} + +1; \ No newline at end of file diff --git a/lib/WebGUI/Middleware/WGAccess.pm b/lib/WebGUI/Middleware/WGAccess.pm new file mode 100644 index 000000000..74e23c169 --- /dev/null +++ b/lib/WebGUI/Middleware/WGAccess.pm @@ -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; diff --git a/lib/WebGUI/Paths.pm b/lib/WebGUI/Paths.pm index ef2dfc446..22238e932 100644 --- a/lib/WebGUI/Paths.pm +++ b/lib/WebGUI/Paths.pm @@ -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) { diff --git a/lib/WebGUI/SQL.pm b/lib/WebGUI/SQL.pm index 6f1f6fd00..c8c824756 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -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 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); } diff --git a/lib/WebGUI/SQL/ResultSet.pm b/lib/WebGUI/SQL/ResultSet.pm index ad0d25c46..fc8216a6f 100644 --- a/lib/WebGUI/SQL/ResultSet.pm +++ b/lib/WebGUI/SQL/ResultSet.pm @@ -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; diff --git a/lib/WebGUI/Search/Index.pm b/lib/WebGUI/Search/Index.pm index 1ac78afbe..1538cd09d 100644 --- a/lib/WebGUI/Search/Index.pm +++ b/lib/WebGUI/Search/Index.pm @@ -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 diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 07e2f5852..fc76b7512 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -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 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 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 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 object, or undef if it doesn't exist. =cut @@ -587,6 +569,19 @@ sub request { #------------------------------------------------------------------- +=head2 response ( ) + +Returns the L 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'); } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/DateTime.pm b/lib/WebGUI/Session/DateTime.pm index a07f4f832..bd7f0067b 100644 --- a/lib/WebGUI/Session/DateTime.pm +++ b/lib/WebGUI/Session/DateTime.pm @@ -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; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/Env.pm b/lib/WebGUI/Session/Env.pm index b338c2167..2f2965c89 100644 --- a/lib/WebGUI/Session/Env.pm +++ b/lib/WebGUI/Session/Env.pm @@ -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'; } diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 5a9fb30eb..89c3fc6c1 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -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("

Fatal Internal Error

"); - $self->session->output->print("

".$message."

"); - } - elsif ($self->canShowDebug()) { - $self->session->output->print("

WebGUI Fatal Error

Something unexpected happened that caused this system to fault.

\n",1); - $self->session->output->print("

".$message."

\n",1); - $self->session->output->print("
" . encode_entities($self->getStackTrace) . "
", 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("

Problem With Request

- 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.
",1); - $self->session->output->print('
'.$self->session->setting->get("companyName"),1); - $self->session->output->print('
'.$self->session->setting->get("companyEmail"),1); - $self->session->output->print('
'.$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 = '
'; - my $text = $self->{_debug_error}; - $text = encode_entities($text); - $output .= '
'.$text."
"; - $text = $self->{_debug_warn}; - $text = encode_entities($text); - $output .= '
'.$text."
"; - $text = $self->{_debug_info}; - $text = encode_entities($text); - $output .= '
'.$text."
"; - 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 .= '
'.$text."
"; - $text = $self->{_debug_debug}; - $text = encode_entities($text); - $output .= '
'.$text."
"; - $output .= '
'; - 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; diff --git a/lib/WebGUI/Session/Form.pm b/lib/WebGUI/Session/Form.pm index 71902060e..d2e79038b 100644 --- a/lib/WebGUI/Session/Form.pm +++ b/lib/WebGUI/Session/Form.pm @@ -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}; } diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 220d1daf7..8aee3ee82 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -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, + }; } diff --git a/lib/WebGUI/Session/Icon.pm b/lib/WebGUI/Session/Icon.pm index 173a2f07f..54d899450 100644 --- a/lib/WebGUI/Session/Icon.pm +++ b/lib/WebGUI/Session/Icon.pm @@ -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; } diff --git a/lib/WebGUI/Session/Id.pm b/lib/WebGUI/Session/Id.pm index 950fd64c2..905de195f 100644 --- a/lib/WebGUI/Session/Id.pm +++ b/lib/WebGUI/Session/Id.pm @@ -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; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/Os.pm b/lib/WebGUI/Session/Os.pm deleted file mode 100644 index 0ef85f30a..000000000 --- a/lib/WebGUI/Session/Os.pm +++ /dev/null @@ -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; diff --git a/lib/WebGUI/Session/Output.pm b/lib/WebGUI/Session/Output.pm index fdff0c997..0059301f4 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -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; diff --git a/lib/WebGUI/Session/Privilege.pm b/lib/WebGUI/Session/Privilege.pm index c6b0b7161..94cc70c51 100644 --- a/lib/WebGUI/Session/Privilege.pm +++ b/lib/WebGUI/Session/Privilege.pm @@ -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; } diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm new file mode 100644 index 000000000..2a9113529 --- /dev/null +++ b/lib/WebGUI/Session/Request.pm @@ -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. + +An instance of this object is created automatically when the L +is created. + +=head1 METHODS + +=head2 new_response () + +Creates a new L object. + +N.B. A L object is automatically created when L +is instantiated, so in most cases you will not need to call this method. +See L + +=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; \ No newline at end of file diff --git a/lib/WebGUI/Session/Response.pm b/lib/WebGUI/Session/Response.pm new file mode 100644 index 000000000..f94b196e9 --- /dev/null +++ b/lib/WebGUI/Session/Response.pm @@ -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. + +An instance of this object is created automatically when the L +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; \ No newline at end of file diff --git a/lib/WebGUI/Session/Scratch.pm b/lib/WebGUI/Session/Scratch.pm index 01e71df91..6672082f4 100644 --- a/lib/WebGUI/Session/Scratch.pm +++ b/lib/WebGUI/Session/Scratch.pm @@ -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; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/Setting.pm b/lib/WebGUI/Session/Setting.pm index 60f0c5bd2..1c1fdcaa4 100644 --- a/lib/WebGUI/Session/Setting.pm +++ b/lib/WebGUI/Session/Setting.pm @@ -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; } diff --git a/lib/WebGUI/Session/Stow.pm b/lib/WebGUI/Session/Stow.pm index 181517cad..3cc0632de 100644 --- a/lib/WebGUI/Session/Stow.pm +++ b/lib/WebGUI/Session/Stow.pm @@ -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; } diff --git a/lib/WebGUI/Session/Style.pm b/lib/WebGUI/Session/Style.pm index 37336d032..374c57285 100644 --- a/lib/WebGUI/Session/Style.pm +++ b/lib/WebGUI/Session/Style.pm @@ -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; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/Url.pm b/lib/WebGUI/Session/Url.pm index 34d7ecb10..1b5fc6902 100644 --- a/lib/WebGUI/Session/Url.pm +++ b/lib/WebGUI/Session/Url.pm @@ -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; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/Var.pm b/lib/WebGUI/Session/Var.pm index ffcf60f68..1dba94d22 100644 --- a/lib/WebGUI/Session/Var.pm +++ b/lib/WebGUI/Session/Var.pm @@ -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); } diff --git a/lib/WebGUI/Shop/Address.pm b/lib/WebGUI/Shop/Address.pm index 8448a6f85..49631c78c 100644 --- a/lib/WebGUI/Shop/Address.pm +++ b/lib/WebGUI/Shop/Address.pm @@ -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; } diff --git a/lib/WebGUI/Shop/AddressBook.pm b/lib/WebGUI/Shop/AddressBook.pm index 06d95afd5..dd23e7c41 100644 --- a/lib/WebGUI/Shop/AddressBook.pm +++ b/lib/WebGUI/Shop/AddressBook.pm @@ -91,7 +91,6 @@ sub delete { $address->delete; } $self->session->db->write("delete from addressBook where addressBookId=?",[$self->getId]); - undef $self; return undef; } diff --git a/lib/WebGUI/Shop/Transaction.pm b/lib/WebGUI/Shop/Transaction.pm index bc707daee..7b3535232 100644 --- a/lib/WebGUI/Shop/Transaction.pm +++ b/lib/WebGUI/Shop/Transaction.pm @@ -182,7 +182,6 @@ sub delete { $item->delete; } $self->session->db->write("delete from transaction where transactionId=?",[$self->getId]); - undef $self; return undef; } diff --git a/lib/WebGUI/Shop/TransactionItem.pm b/lib/WebGUI/Shop/TransactionItem.pm index ffa57cb59..838e0eb2e 100644 --- a/lib/WebGUI/Shop/TransactionItem.pm +++ b/lib/WebGUI/Shop/TransactionItem.pm @@ -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; } diff --git a/lib/WebGUI/Storage.pm b/lib/WebGUI/Storage.pm index c988d1b73..575a4b049 100644 --- a/lib/WebGUI/Storage.pm +++ b/lib/WebGUI/Storage.pm @@ -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'} diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm deleted file mode 100644 index fa6128bba..000000000 --- a/lib/WebGUI/URL/Content.pm +++ /dev/null @@ -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; - diff --git a/lib/WebGUI/URL/PassThru.pm b/lib/WebGUI/URL/PassThru.pm deleted file mode 100644 index d07a268ec..000000000 --- a/lib/WebGUI/URL/PassThru.pm +++ /dev/null @@ -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; - diff --git a/lib/WebGUI/URL/Snoop.pm b/lib/WebGUI/URL/Snoop.pm deleted file mode 100644 index 58ee708fe..000000000 --- a/lib/WebGUI/URL/Snoop.pm +++ /dev/null @@ -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|Snoopy
Why would you type in this URL? Really. What were you expecting to see here? You really need to get a life. Are you still here? Seriously, you need to go do something else. I think your boss is calling.
|); - return Apache2::Const::OK; - } ); - $request->push_handlers(PerlTransHandler => sub { return Apache2::Const::OK }); - return Apache2::Const::OK; -} - - -1; - diff --git a/lib/WebGUI/URL/Unauthorized.pm b/lib/WebGUI/URL/Unauthorized.pm deleted file mode 100644 index 6665c1cfd..000000000 --- a/lib/WebGUI/URL/Unauthorized.pm +++ /dev/null @@ -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; - diff --git a/lib/WebGUI/URL/Uploads.pm b/lib/WebGUI/URL/Uploads.pm deleted file mode 100644 index bea5a99f7..000000000 --- a/lib/WebGUI/URL/Uploads.pm +++ /dev/null @@ -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; - diff --git a/lib/WebGUI/URL/_url.skeleton b/lib/WebGUI/URL/_url.skeleton deleted file mode 100644 index 4faceab04..000000000 --- a/lib/WebGUI/URL/_url.skeleton +++ /dev/null @@ -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 diff --git a/lib/WebGUI/Workflow.pm b/lib/WebGUI/Workflow.pm index 4232fdf63..5b2d505d5 100644 --- a/lib/WebGUI/Workflow.pm +++ b/lib/WebGUI/Workflow.pm @@ -163,21 +163,6 @@ sub demoteActivity { } } - -#------------------------------------------------------------------- - -=head2 DESTROY ( ) - -Deconstructor. - -=cut - -sub DESTROY { - my $self = shift; - undef $self; -} - - #------------------------------------------------------------------- =head2 get ( name ) diff --git a/lib/WebGUI/Workflow/Activity.pm b/lib/WebGUI/Workflow/Activity.pm index 23bfb6ee6..25f8833d9 100644 --- a/lib/WebGUI/Workflow/Activity.pm +++ b/lib/WebGUI/Workflow/Activity.pm @@ -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 ) diff --git a/lib/WebGUI/Workflow/Activity/SendWebguiStats.pm b/lib/WebGUI/Workflow/Activity/SendWebguiStats.pm index c032e01a7..6b987a773 100644 --- a/lib/WebGUI/Workflow/Activity/SendWebguiStats.pm +++ b/lib/WebGUI/Workflow/Activity/SendWebguiStats.pm @@ -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"), diff --git a/lib/WebGUI/Workflow/Cron.pm b/lib/WebGUI/Workflow/Cron.pm index 1e0532bd7..a152965b4 100644 --- a/lib/WebGUI/Workflow/Cron.pm +++ b/lib/WebGUI/Workflow/Cron.pm @@ -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 ) diff --git a/lib/WebGUI/Workflow/Instance.pm b/lib/WebGUI/Workflow/Instance.pm index a0df11343..7136b9303 100644 --- a/lib/WebGUI/Workflow/Instance.pm +++ b/lib/WebGUI/Workflow/Instance.pm @@ -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; } diff --git a/lib/WebGUI/Workflow/Spectre.pm b/lib/WebGUI/Workflow/Spectre.pm index 6ed59ac34..cc348affc 100644 --- a/lib/WebGUI/Workflow/Spectre.pm +++ b/lib/WebGUI/Workflow/Spectre.pm @@ -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. diff --git a/sbin/fileImport.pl b/sbin/fileImport.pl index e71dfc5ae..3c00104be 100755 --- a/sbin/fileImport.pl +++ b/sbin/fileImport.pl @@ -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); } diff --git a/sbin/testEnvironment.pl b/sbin/testEnvironment.pl index 3bba9f445..2fbbb2beb 100755 --- a/sbin/testEnvironment.pl +++ b/sbin/testEnvironment.pl @@ -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" ); diff --git a/t/Asset/Template.t b/t/Asset/Template.t index 5c985ac40..5a92c1c1c 100644 --- a/t/Asset/Template.t +++ b/t/Asset/Template.t @@ -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 ) }; diff --git a/t/Auth.t b/t/Auth.t index 571011797..001e00016 100644 --- a/t/Auth.t +++ b/t/Auth.t @@ -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 { diff --git a/t/Exception/app.t b/t/Exception/app.t new file mode 100644 index 000000000..fa2f77a91 --- /dev/null +++ b/t/Exception/app.t @@ -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/; +}; + diff --git a/t/PSGI/default-site.t b/t/PSGI/default-site.t new file mode 100644 index 000000000..b2799756d --- /dev/null +++ b/t/PSGI/default-site.t @@ -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/; + +}; diff --git a/t/Session/Os.t b/t/Session/Os.t deleted file mode 100644 index 9fd1f7bfb..000000000 --- a/t/Session/Os.t +++ /dev/null @@ -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"); -} - diff --git a/t/Session/Url.t b/t/Session/Url.t index 406651aaf..b82b20f16 100644 --- a/t/Session/Url.t +++ b/t/Session/Url.t @@ -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:/; diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index 693377c8c..ccd4666c8 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -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 ); } }, ); diff --git a/var/site.psgi b/var/site.psgi new file mode 100644 index 000000000..32dd72e6f --- /dev/null +++ b/var/site.psgi @@ -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; +}; +