From eb446e7eed6a132582df44ff4b956a0f6e753eaf Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 20:31:28 +1100 Subject: [PATCH 01/92] FakeApache --- lib/WebGUI/Session.pm | 3 +- lib/WebGUI/Session/Request.pm | 508 ++++++++++++++++++++++++++++++++++ 2 files changed, 510 insertions(+), 1 deletion(-) create mode 100644 lib/WebGUI/Session/Request.pm diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 3b5063a3f..56003a8fd 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -29,6 +29,7 @@ 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; @@ -463,7 +464,7 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - $self->{_request} = $request if (defined $request); + $self->{_request} = WebGUI::Session::Request->new( r => $request, env => {}, session => $self ) if $request; my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm new file mode 100644 index 000000000..575a7befd --- /dev/null +++ b/lib/WebGUI/Session/Request.pm @@ -0,0 +1,508 @@ +package WebGUI::Session::Request; +# We need to define an Apache package or we might get strange errors +# like "Can't locate package Apache for +# @WebGUI::Session::Request::ISA". We do the BEGIN/eval thing so that +# the CPAN indexer doesn't pick it up, which would be ugly. +#BEGIN { eval "package Apache" } +@WebGUI::Session::Request::ISA = qw(Apache); +# Analogous to Apache request object $r (but not an actual Apache subclass) +# In the future we'll probably want to switch this to Apache::Fake or similar + +use strict; +use warnings; +use CGI; + +sub new { + my $class = shift; + my %p = @_; + return bless { + %p, + query => $p{cgi} || CGI->new, + headers_out => WebGUI::Session::Request::FakeTable->new, + err_headers_out => WebGUI::Session::Request::FakeTable->new, + pnotes => {}, + }, $class; +} + +sub session { $_[0]{session} } +sub env { $_[0]{env} } +sub r { $_[0]{r} } + +our $AUTOLOAD; + +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + my $r = $self->r; + + if (!$r) { + $self->session->log->error("!!session->request->$what(@_) but r not defined"); + return; + } + + $self->session->log->error("!!session->request->$what(@_)"); + return $r->$what(@_); +} + +# CGI request are _always_ main, and there is never a previous or a next +# internal request. +sub main {} +sub prev {} +sub next {} +sub is_main {1} +sub is_initial_req {1} + +# What to do with this? +# sub allowed {} + +sub method { + $_[0]->query->request_method; +} + +# There mut be a mapping for this. +# sub method_number {} + +# Can CGI.pm tell us this? +# sub bytes_sent {0} + +# The request line sent by the client." Poached from Apache::Emulator. +sub the_request { + my $self = shift; + $self->{the_request} ||= join ' ', $self->method, + ( $self->{query}->query_string + ? $self->uri . '?' . $self->{query}->query_string + : $self->uri ), + $self->{query}->server_protocol; +} + +# Is CGI ever a proxy request? +# sub proxy_req {} + +sub header_only { $_[0]->method eq 'HEAD' } + +sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } + +sub hostname { $_[0]->{query}->server_name } + +# CGI says "use this when using virtual hosts". It falls back to +# CGI->server_port. +sub get_server_port { $_[0]->{query}->virtual_port } + +# Fake it by just giving the current time. +sub request_time { time } + +sub uri { + my $self = shift; + + $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; +} + +# Is this available in CGI? +# sub filename {} + +# "The $r->location method will return the path of the +# section from which the current "Perl*Handler" +# is being called." This is irrelevant, I think. +# sub location {} + +sub path_info { $_[0]->{query}->path_info } + +sub args { + my $self = shift; + if (@_) { + # Assign args here. + } + return $self->{query}->Vars unless wantarray; + # Do more here to return key => arg values. +} + +sub headers_in { + my $self = shift; + + # Create the headers table if necessary. Decided how to build it based on + # information here: + # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 + # + # Try to get as much info as possible from CGI.pm, which has + # workarounds for things like the IIS PATH_INFO bug. + # + $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new + ( 'Authorization' => $self->{query}->auth_type, # No credentials though. + 'Content-Length' => $ENV{CONTENT_LENGTH}, + 'Content-Type' => + ( $self->{query}->can('content_type') ? + $self->{query}->content_type : + $ENV{CONTENT_TYPE} + ), + # Convert HTTP environment variables back into their header names. + map { + my $k = ucfirst lc; + $k =~ s/_(.)/-\u$1/g; + ( $k => $self->{query}->http($_) ) + } grep { s/^HTTP_// } keys %ENV + ); + + + # Give 'em the hash list of the hash table. + return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; +} + +sub header_in { + my ($self, $header) = (shift, shift); + my $h = $self->headers_in; + return @_ ? $h->set($header, shift) : $h->get($header); +} + + +# The $r->content method will return the entity body +# read from the client, but only if the request content +# type is "application/x-www-form-urlencoded". When +# called in a scalar context, the entire string is +# returned. When called in a list context, a list of +# parsed key => value pairs are returned. *NOTE*: you +# can only ask for this once, as the entire body is read +# from the client. +# Not sure what to do with this one. +# sub content {} + +# I think this may be irrelevant under CGI. +# sub read {} + +# Use LWP? +sub get_remote_host {} +sub get_remote_logname {} + +sub http_header { + my $self = shift; + my $h = $self->headers_out; + my $e = $self->err_headers_out; + my $method = exists $h->{Location} || exists $e->{Location} ? + 'redirect' : 'header'; + return $self->query->$method(tied(%$h)->cgi_headers, + tied(%$e)->cgi_headers); +} + +sub send_http_header { + my $self = shift; + + return if $self->http_header_sent; + + print STDOUT $self->http_header; + + $self->{http_header_sent} = 1; +} + +sub http_header_sent { shift->{http_header_sent} } + +# How do we know this under CGI? +# sub get_basic_auth_pw {} +# sub note_basic_auth_failure {} + +# I think that this just has to be empty. +sub handler {} + +sub notes { + my ($self, $key) = (shift, shift); + $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; + return wantarray ? %{$self->{notes}} : $self->{notes} + unless defined $key; + return $self->{notes}{$key} = "$_[0]" if @_; + return $self->{notes}{$key}; +} + +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 subprocess_env { + my ($self, $key) = (shift, shift); + unless (defined $key) { + $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); + return wantarray ? %{$self->{subprocess_env}} : + $self->{subprocess_env}; + + } + $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); + return $self->{subprocess_env}{$key} = "$_[0]" if @_; + return $self->{subprocess_env}{$key}; +} + +sub content_type { + shift->header_out('Content-Type', @_); +} + +sub content_encoding { + shift->header_out('Content-Encoding', @_); +} + +sub content_languages { + my ($self, $langs) = @_; + return unless $langs; + my $h = shift->headers_out; + for my $l (@$langs) { + $h->add('Content-Language', $l); + } +} + +sub status { + shift->header_out('Status', @_); +} + +sub status_line { + # What to do here? Should it be managed differently than status? + my $self = shift; + if (@_) { + my $status = shift =~ /^(\d+)/; + return $self->header_out('Status', $status); + } + return $self->header_out('Status'); +} + +sub headers_out { + my $self = shift; + return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; +} + +sub header_out { + my ($self, $header) = (shift, shift); + my $h = $self->headers_out; + return @_ ? $h->set($header, shift) : $h->get($header); +} + +sub err_headers_out { + my $self = shift; + return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; +} + +sub err_header_out { + my ($self, $err_header) = (shift, shift); + my $h = $self->err_headers_out; + return @_ ? $h->set($err_header, shift) : $h->get($err_header); +} + +sub no_cache { + my $self = shift; + $self->header_out(Pragma => 'no-cache'); + $self->header_out('Cache-Control' => 'no-cache'); +} + +sub print { + shift; + print @_; +} + +sub send_fd { + my ($self, $fd) = @_; + local $_; + + print STDOUT while defined ($_ = <$fd>); +} + +# Should this perhaps throw an exception? +# sub internal_redirect {} +# sub internal_redirect_handler {} + +# Do something with ErrorDocument? +# sub custom_response {} + +# I think we've made this essentially the same thing. +BEGIN { + local $^W; + *send_cgi_header = \&send_http_header; +} + +# Does CGI support logging? +# sub log_reason {} +# sub log_error {} +sub warn { + shift; + print STDERR @_, "\n"; +} + +sub params { + my $self = shift; + return _cgi_request_args($self->query, $self->query->request_method); +} + +sub _cgi_request_args{ + my ($q, $method) = @_; + + my %args; + + # Checking that there really is no query string when the method is + # not POST is important because otherwise ->url_param returns a + # parameter named 'keywords' with a value of () (empty array). + # This is apparently a feature related to queries or + # something (see the CGI.pm) docs. It makes my head hurt. - dave + my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); + + foreach my $key ( map { $q->$_() } @methods ) { + next if exists $args{$key}; + my @values = map { $q->$_($key) } @methods; + $args{$key} = @values == 1 ? $values[0] : \@values; + } + + return wantarray ? %args : \%args; +} + + +########################################################### +package WebGUI::Session::Request::FakeTable; +# Analogous to Apache::Table. +use strict; +use warnings; + +sub new { + my $class = shift; + my $self = {}; + tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; + %$self = @_ if @_; + return bless $self, ref $class || $class; +} + +sub set { + my ($self, $header, $value) = @_; + defined $value ? $self->{$header} = $value : delete $self->{$header}; +} + +sub unset { + my $self = shift; + delete $self->{shift()}; +} + +sub add { + tied(%{shift()})->add(@_); +} + +sub clear { + %{shift()} = (); +} + +sub get { + tied(%{shift()})->get(@_); +} + +sub merge { + my ($self, $key, $value) = @_; + if (defined $self->{$key}) { + $self->{$key} .= ',' . $value; + } else { + $self->{$key} = "$value"; + } +} + +sub do { + my ($self, $code) = @_; + while (my ($k, $val) = each %$self) { + for my $v (ref $val ? @$val : $val) { + return unless $code->($k => $v); + } + } +} + +########################################################### +package WebGUI::Session::Request::FakeTableHash; +# Used by WebGUI::Session::Request::FakeTable. +use strict; +use warnings; + +sub TIEHASH { + my $class = shift; + return bless {}, ref $class || $class; +} + +sub _canonical_key { + my $key = lc shift; + # CGI really wants a - before each header + return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; +} + +sub STORE { + my ($self, $key, $value) = @_; + $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; +} + +sub add { + my ($self, $key) = (shift, shift); + return unless defined $_[0]; + my $value = ref $_[0] ? "$_[0]" : $_[0]; + my $ckey = _canonical_key $key; + if (exists $self->{$ckey}) { + if (ref $self->{$ckey}[1]) { + push @{$self->{$ckey}[1]}, $value; + } else { + $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; + } + } else { + $self->{$ckey} = [ $key => $value ]; + } +} + +sub DELETE { + my ($self, $key) = @_; + my $ret = delete $self->{_canonical_key $key}; + return $ret->[1]; +} + +sub FETCH { + my ($self, $key) = @_; + # Grab the values first so that we don't autovivicate the key. + my $val = $self->{_canonical_key $key} or return; + if (my $ref = ref $val->[1]) { + return unless $val->[1][0]; + # Return the first value only. + return $val->[1][0]; + } + return $val->[1]; +} + +sub get { + my ($self, $key) = @_; + my $ckey = _canonical_key $key; + return unless exists $self->{$ckey}; + return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; + return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; +} + +sub CLEAR { + %{shift()} = (); +} + +sub EXISTS { + my ($self, $key)= @_; + return exists $self->{_canonical_key $key}; +} + +sub FIRSTKEY { + my $self = shift; + # Reset perl's iterator. + keys %$self; + # Get the first key via perl's iterator. + my $first_key = each %$self; + return undef unless defined $first_key; + return $self->{$first_key}[0]; +} + +sub NEXTKEY { + my ($self, $nextkey) = @_; + # Get the next key via perl's iterator. + my $next_key = each %$self; + return undef unless defined $next_key; + return $self->{$next_key}[0]; +} + +sub cgi_headers { + my $self = shift; + map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; +} + +sub _map_header_key_to_cgi_key { + return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; +} + +1; From be755abaa9e639ef1b84cb6445289c74d6e0bb1d Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 21:02:10 +1100 Subject: [PATCH 02/92] simple dualism --- etc/dev.localhost.localdomain.psgi | 34 + lib/WebGUI.pm | 28 + lib/WebGUI/Session.pm | 2 +- lib/WebGUI/Session/Request.pm | 956 +++++++++++++++-------------- lib/WebGUI/URL/Content.pm | 49 ++ 5 files changed, 604 insertions(+), 465 deletions(-) create mode 100644 etc/dev.localhost.localdomain.psgi diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi new file mode 100644 index 000000000..4e5dad288 --- /dev/null +++ b/etc/dev.localhost.localdomain.psgi @@ -0,0 +1,34 @@ +BEGIN { + # This is just a temporary hack + our $WEBGUI_ROOT = '/data/WebGUI'; + our $WEBGUI_DOMAINS = '/data/domains'; + our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; +} +use local::lib $WEBGUI_ROOT; +use WebGUI; +use Plack::Middleware qw( Static XFramework AccessLog ); +use Plack::Builder; + +my $app = sub { + my $env = shift; + $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; + $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; + WebGUI::handle_psgi($env); +}; + +# Apply some Middleware +builder { + # /extras + enable Plack::Middleware::Static + path => qr{^/extras/}, root => "$WEBGUI_ROOT/www/"; + + # /uploads (ignore .wgaccess for now..) + enable Plack::Middleware::Static + path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; + + enable Plack::Middleware::XFramework framework => 'WebGUI'; + + enable Plack::Middleware::AccessLog format => "combined"; + + $app; +} \ No newline at end of file diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 460466137..5da74d210 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -207,8 +207,36 @@ sub handler { return Apache2::Const::DECLINED; } +sub handle_psgi { + my $env = shift; + my $request = WebGUI::Session::Request->new( env => $env ); + my $config = WebGUI::Config->new( $env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'} ); + my $server; + my $error = ""; + my $matchUri = $request->plack->request_uri; + my $gateway = $config->get("gateway"); + $matchUri =~ s{^$gateway}{/}; + # We should probably ditch URL Handlers altogether in favour of Plack::Middleware + 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; + } + return $output if $output; + } + } + # can't handle the url due to error or misconfiguration + return [ + 500, + [ 'Content-Type' => 'text/html' ], + ["This server is unable to handle the url '$matchUri' that you requested. $error"] + ]; +} 1; diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 56003a8fd..7d3c5d1fb 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -464,7 +464,7 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - $self->{_request} = WebGUI::Session::Request->new( r => $request, env => {}, session => $self ) if $request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm index 575a7befd..e988a96d7 100644 --- a/lib/WebGUI/Session/Request.pm +++ b/lib/WebGUI/Session/Request.pm @@ -1,10 +1,12 @@ package WebGUI::Session::Request; + # We need to define an Apache package or we might get strange errors # like "Can't locate package Apache for # @WebGUI::Session::Request::ISA". We do the BEGIN/eval thing so that # the CPAN indexer doesn't pick it up, which would be ugly. #BEGIN { eval "package Apache" } @WebGUI::Session::Request::ISA = qw(Apache); + # Analogous to Apache request object $r (but not an actual Apache subclass) # In the future we'll probably want to switch this to Apache::Fake or similar @@ -14,19 +16,30 @@ use CGI; sub new { my $class = shift; - my %p = @_; - return bless { + my %p = @_; + + my $self = bless { %p, - query => $p{cgi} || CGI->new, - headers_out => WebGUI::Session::Request::FakeTable->new, - err_headers_out => WebGUI::Session::Request::FakeTable->new, + + # query => $p{cgi} || CGI->new, + # headers_out => WebGUI::Session::Request::FakeTable->new, + # err_headers_out => WebGUI::Session::Request::FakeTable->new, pnotes => {}, }, $class; + + if ( $p{env} ) { + require Plack::Request; + require Plack::Response; + $self->{plack} = Plack::Request->new( $p{env} ); + } + + return $self; } sub session { $_[0]{session} } sub env { $_[0]{env} } sub r { $_[0]{r} } +sub plack { $_[0]{plack} } our $AUTOLOAD; @@ -35,474 +48,489 @@ sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; my $r = $self->r; - - if (!$r) { - $self->session->log->error("!!session->request->$what(@_) but r not defined"); + + if ( !$r ) { + $self->log("!!request->$what(@_) but r not defined"); return; } - - $self->session->log->error("!!session->request->$what(@_)"); + + if ( $what eq 'print' ) { + $self->log("!!request->$what(print--chomped)"); + } + else { + $self->log("!!request->$what(@_)"); + } return $r->$what(@_); } -# CGI request are _always_ main, and there is never a previous or a next -# internal request. -sub main {} -sub prev {} -sub next {} -sub is_main {1} -sub is_initial_req {1} - -# What to do with this? -# sub allowed {} - -sub method { - $_[0]->query->request_method; -} - -# There mut be a mapping for this. -# sub method_number {} - -# Can CGI.pm tell us this? -# sub bytes_sent {0} - -# The request line sent by the client." Poached from Apache::Emulator. -sub the_request { +sub log { my $self = shift; - $self->{the_request} ||= join ' ', $self->method, - ( $self->{query}->query_string - ? $self->uri . '?' . $self->{query}->query_string - : $self->uri ), - $self->{query}->server_protocol; -} - -# Is CGI ever a proxy request? -# sub proxy_req {} - -sub header_only { $_[0]->method eq 'HEAD' } - -sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } - -sub hostname { $_[0]->{query}->server_name } - -# CGI says "use this when using virtual hosts". It falls back to -# CGI->server_port. -sub get_server_port { $_[0]->{query}->virtual_port } - -# Fake it by just giving the current time. -sub request_time { time } - -sub uri { - my $self = shift; - - $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; -} - -# Is this available in CGI? -# sub filename {} - -# "The $r->location method will return the path of the -# section from which the current "Perl*Handler" -# is being called." This is irrelevant, I think. -# sub location {} - -sub path_info { $_[0]->{query}->path_info } - -sub args { - my $self = shift; - if (@_) { - # Assign args here. + if ( $self->session ) { + $self->session->log->error(shift); } - return $self->{query}->Vars unless wantarray; - # Do more here to return key => arg values. -} - -sub headers_in { - my $self = shift; - - # Create the headers table if necessary. Decided how to build it based on - # information here: - # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 - # - # Try to get as much info as possible from CGI.pm, which has - # workarounds for things like the IIS PATH_INFO bug. - # - $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new - ( 'Authorization' => $self->{query}->auth_type, # No credentials though. - 'Content-Length' => $ENV{CONTENT_LENGTH}, - 'Content-Type' => - ( $self->{query}->can('content_type') ? - $self->{query}->content_type : - $ENV{CONTENT_TYPE} - ), - # Convert HTTP environment variables back into their header names. - map { - my $k = ucfirst lc; - $k =~ s/_(.)/-\u$1/g; - ( $k => $self->{query}->http($_) ) - } grep { s/^HTTP_// } keys %ENV - ); - - - # Give 'em the hash list of the hash table. - return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; -} - -sub header_in { - my ($self, $header) = (shift, shift); - my $h = $self->headers_in; - return @_ ? $h->set($header, shift) : $h->get($header); -} - - -# The $r->content method will return the entity body -# read from the client, but only if the request content -# type is "application/x-www-form-urlencoded". When -# called in a scalar context, the entire string is -# returned. When called in a list context, a list of -# parsed key => value pairs are returned. *NOTE*: you -# can only ask for this once, as the entire body is read -# from the client. -# Not sure what to do with this one. -# sub content {} - -# I think this may be irrelevant under CGI. -# sub read {} - -# Use LWP? -sub get_remote_host {} -sub get_remote_logname {} - -sub http_header { - my $self = shift; - my $h = $self->headers_out; - my $e = $self->err_headers_out; - my $method = exists $h->{Location} || exists $e->{Location} ? - 'redirect' : 'header'; - return $self->query->$method(tied(%$h)->cgi_headers, - tied(%$e)->cgi_headers); -} - -sub send_http_header { - my $self = shift; - - return if $self->http_header_sent; - - print STDOUT $self->http_header; - - $self->{http_header_sent} = 1; -} - -sub http_header_sent { shift->{http_header_sent} } - -# How do we know this under CGI? -# sub get_basic_auth_pw {} -# sub note_basic_auth_failure {} - -# I think that this just has to be empty. -sub handler {} - -sub notes { - my ($self, $key) = (shift, shift); - $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; - return wantarray ? %{$self->{notes}} : $self->{notes} - unless defined $key; - return $self->{notes}{$key} = "$_[0]" if @_; - return $self->{notes}{$key}; -} - -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 subprocess_env { - my ($self, $key) = (shift, shift); - unless (defined $key) { - $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); - return wantarray ? %{$self->{subprocess_env}} : - $self->{subprocess_env}; - - } - $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); - return $self->{subprocess_env}{$key} = "$_[0]" if @_; - return $self->{subprocess_env}{$key}; -} - -sub content_type { - shift->header_out('Content-Type', @_); -} - -sub content_encoding { - shift->header_out('Content-Encoding', @_); -} - -sub content_languages { - my ($self, $langs) = @_; - return unless $langs; - my $h = shift->headers_out; - for my $l (@$langs) { - $h->add('Content-Language', $l); + else { + warn shift; } } -sub status { - shift->header_out('Status', @_); -} - -sub status_line { - # What to do here? Should it be managed differently than status? - my $self = shift; - if (@_) { - my $status = shift =~ /^(\d+)/; - return $self->header_out('Status', $status); - } - return $self->header_out('Status'); -} - -sub headers_out { - my $self = shift; - return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; -} - -sub header_out { - my ($self, $header) = (shift, shift); - my $h = $self->headers_out; - return @_ ? $h->set($header, shift) : $h->get($header); -} - -sub err_headers_out { - my $self = shift; - return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; -} - -sub err_header_out { - my ($self, $err_header) = (shift, shift); - my $h = $self->err_headers_out; - return @_ ? $h->set($err_header, shift) : $h->get($err_header); -} - -sub no_cache { - my $self = shift; - $self->header_out(Pragma => 'no-cache'); - $self->header_out('Cache-Control' => 'no-cache'); -} - -sub print { - shift; - print @_; -} - -sub send_fd { - my ($self, $fd) = @_; - local $_; - - print STDOUT while defined ($_ = <$fd>); -} - -# Should this perhaps throw an exception? -# sub internal_redirect {} -# sub internal_redirect_handler {} - -# Do something with ErrorDocument? -# sub custom_response {} - -# I think we've made this essentially the same thing. -BEGIN { - local $^W; - *send_cgi_header = \&send_http_header; -} - -# Does CGI support logging? -# sub log_reason {} -# sub log_error {} -sub warn { - shift; - print STDERR @_, "\n"; -} - -sub params { - my $self = shift; - return _cgi_request_args($self->query, $self->query->request_method); -} - -sub _cgi_request_args{ - my ($q, $method) = @_; - - my %args; - - # Checking that there really is no query string when the method is - # not POST is important because otherwise ->url_param returns a - # parameter named 'keywords' with a value of () (empty array). - # This is apparently a feature related to queries or - # something (see the CGI.pm) docs. It makes my head hurt. - dave - my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); - - foreach my $key ( map { $q->$_() } @methods ) { - next if exists $args{$key}; - my @values = map { $q->$_($key) } @methods; - $args{$key} = @values == 1 ? $values[0] : \@values; - } - - return wantarray ? %args : \%args; -} - - -########################################################### -package WebGUI::Session::Request::FakeTable; -# Analogous to Apache::Table. -use strict; -use warnings; - -sub new { - my $class = shift; - my $self = {}; - tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; - %$self = @_ if @_; - return bless $self, ref $class || $class; -} - -sub set { - my ($self, $header, $value) = @_; - defined $value ? $self->{$header} = $value : delete $self->{$header}; -} - -sub unset { - my $self = shift; - delete $self->{shift()}; -} - -sub add { - tied(%{shift()})->add(@_); -} - -sub clear { - %{shift()} = (); -} - -sub get { - tied(%{shift()})->get(@_); -} - -sub merge { - my ($self, $key, $value) = @_; - if (defined $self->{$key}) { - $self->{$key} .= ',' . $value; - } else { - $self->{$key} = "$value"; - } -} - -sub do { - my ($self, $code) = @_; - while (my ($k, $val) = each %$self) { - for my $v (ref $val ? @$val : $val) { - return unless $code->($k => $v); - } - } -} - -########################################################### -package WebGUI::Session::Request::FakeTableHash; -# Used by WebGUI::Session::Request::FakeTable. -use strict; -use warnings; - -sub TIEHASH { - my $class = shift; - return bless {}, ref $class || $class; -} - -sub _canonical_key { - my $key = lc shift; - # CGI really wants a - before each header - return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; -} - -sub STORE { - my ($self, $key, $value) = @_; - $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; -} - -sub add { - my ($self, $key) = (shift, shift); - return unless defined $_[0]; - my $value = ref $_[0] ? "$_[0]" : $_[0]; - my $ckey = _canonical_key $key; - if (exists $self->{$ckey}) { - if (ref $self->{$ckey}[1]) { - push @{$self->{$ckey}[1]}, $value; - } else { - $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; - } - } else { - $self->{$ckey} = [ $key => $value ]; - } -} - -sub DELETE { - my ($self, $key) = @_; - my $ret = delete $self->{_canonical_key $key}; - return $ret->[1]; -} - -sub FETCH { - my ($self, $key) = @_; - # Grab the values first so that we don't autovivicate the key. - my $val = $self->{_canonical_key $key} or return; - if (my $ref = ref $val->[1]) { - return unless $val->[1][0]; - # Return the first value only. - return $val->[1][0]; - } - return $val->[1]; -} - -sub get { - my ($self, $key) = @_; - my $ckey = _canonical_key $key; - return unless exists $self->{$ckey}; - return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; - return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; -} - -sub CLEAR { - %{shift()} = (); -} - -sub EXISTS { - my ($self, $key)= @_; - return exists $self->{_canonical_key $key}; -} - -sub FIRSTKEY { - my $self = shift; - # Reset perl's iterator. - keys %$self; - # Get the first key via perl's iterator. - my $first_key = each %$self; - return undef unless defined $first_key; - return $self->{$first_key}[0]; -} - -sub NEXTKEY { - my ($self, $nextkey) = @_; - # Get the next key via perl's iterator. - my $next_key = each %$self; - return undef unless defined $next_key; - return $self->{$next_key}[0]; -} - -sub cgi_headers { - my $self = shift; - map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; -} - -sub _map_header_key_to_cgi_key { - return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; -} +## CGI request are _always_ main, and there is never a previous or a next +## internal request. +#sub main {} +#sub prev {} +#sub next {} +#sub is_main {1} +#sub is_initial_req {1} +# +## What to do with this? +## sub allowed {} +# +#sub method { +# $_[0]->query->request_method; +#} +# +## There mut be a mapping for this. +## sub method_number {} +# +## Can CGI.pm tell us this? +## sub bytes_sent {0} +# +## The request line sent by the client." Poached from Apache::Emulator. +#sub the_request { +# my $self = shift; +# $self->{the_request} ||= join ' ', $self->method, +# ( $self->{query}->query_string +# ? $self->uri . '?' . $self->{query}->query_string +# : $self->uri ), +# $self->{query}->server_protocol; +#} +# +## Is CGI ever a proxy request? +## sub proxy_req {} +# +#sub header_only { $_[0]->method eq 'HEAD' } +# +#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } +# +#sub hostname { $_[0]->{query}->server_name } +# +## CGI says "use this when using virtual hosts". It falls back to +## CGI->server_port. +#sub get_server_port { $_[0]->{query}->virtual_port } +# +## Fake it by just giving the current time. +#sub request_time { time } +# +#sub uri { +# my $self = shift; +# +# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; +#} +# +## Is this available in CGI? +## sub filename {} +# +## "The $r->location method will return the path of the +## section from which the current "Perl*Handler" +## is being called." This is irrelevant, I think. +## sub location {} +# +#sub path_info { $_[0]->{query}->path_info } +# +#sub args { +# my $self = shift; +# if (@_) { +# # Assign args here. +# } +# return $self->{query}->Vars unless wantarray; +# # Do more here to return key => arg values. +#} +# +#sub headers_in { +# my $self = shift; +# +# # Create the headers table if necessary. Decided how to build it based on +# # information here: +# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 +# # +# # Try to get as much info as possible from CGI.pm, which has +# # workarounds for things like the IIS PATH_INFO bug. +# # +# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new +# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. +# 'Content-Length' => $ENV{CONTENT_LENGTH}, +# 'Content-Type' => +# ( $self->{query}->can('content_type') ? +# $self->{query}->content_type : +# $ENV{CONTENT_TYPE} +# ), +# # Convert HTTP environment variables back into their header names. +# map { +# my $k = ucfirst lc; +# $k =~ s/_(.)/-\u$1/g; +# ( $k => $self->{query}->http($_) ) +# } grep { s/^HTTP_// } keys %ENV +# ); +# +# +# # Give 'em the hash list of the hash table. +# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; +#} +# +#sub header_in { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_in; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +# +## The $r->content method will return the entity body +## read from the client, but only if the request content +## type is "application/x-www-form-urlencoded". When +## called in a scalar context, the entire string is +## returned. When called in a list context, a list of +## parsed key => value pairs are returned. *NOTE*: you +## can only ask for this once, as the entire body is read +## from the client. +## Not sure what to do with this one. +## sub content {} +# +## I think this may be irrelevant under CGI. +## sub read {} +# +## Use LWP? +#sub get_remote_host {} +#sub get_remote_logname {} +# +#sub http_header { +# my $self = shift; +# my $h = $self->headers_out; +# my $e = $self->err_headers_out; +# my $method = exists $h->{Location} || exists $e->{Location} ? +# 'redirect' : 'header'; +# return $self->query->$method(tied(%$h)->cgi_headers, +# tied(%$e)->cgi_headers); +#} +# +#sub send_http_header { +# my $self = shift; +# +# return if $self->http_header_sent; +# +# print STDOUT $self->http_header; +# +# $self->{http_header_sent} = 1; +#} +# +#sub http_header_sent { shift->{http_header_sent} } +# +## How do we know this under CGI? +## sub get_basic_auth_pw {} +## sub note_basic_auth_failure {} +# +## I think that this just has to be empty. +#sub handler {} +# +#sub notes { +# my ($self, $key) = (shift, shift); +# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; +# return wantarray ? %{$self->{notes}} : $self->{notes} +# unless defined $key; +# return $self->{notes}{$key} = "$_[0]" if @_; +# return $self->{notes}{$key}; +#} +# +#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 subprocess_env { +# my ($self, $key) = (shift, shift); +# unless (defined $key) { +# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); +# return wantarray ? %{$self->{subprocess_env}} : +# $self->{subprocess_env}; +# +# } +# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); +# return $self->{subprocess_env}{$key} = "$_[0]" if @_; +# return $self->{subprocess_env}{$key}; +#} +# +#sub content_type { +# shift->header_out('Content-Type', @_); +#} +# +#sub content_encoding { +# shift->header_out('Content-Encoding', @_); +#} +# +#sub content_languages { +# my ($self, $langs) = @_; +# return unless $langs; +# my $h = shift->headers_out; +# for my $l (@$langs) { +# $h->add('Content-Language', $l); +# } +#} +# +#sub status { +# shift->header_out('Status', @_); +#} +# +#sub status_line { +# # What to do here? Should it be managed differently than status? +# my $self = shift; +# if (@_) { +# my $status = shift =~ /^(\d+)/; +# return $self->header_out('Status', $status); +# } +# return $self->header_out('Status'); +#} +# +#sub headers_out { +# my $self = shift; +# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; +#} +# +#sub header_out { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_out; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +#sub err_headers_out { +# my $self = shift; +# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; +#} +# +#sub err_header_out { +# my ($self, $err_header) = (shift, shift); +# my $h = $self->err_headers_out; +# return @_ ? $h->set($err_header, shift) : $h->get($err_header); +#} +# +#sub no_cache { +# my $self = shift; +# $self->header_out(Pragma => 'no-cache'); +# $self->header_out('Cache-Control' => 'no-cache'); +#} +# +#sub print { +# shift; +# print @_; +#} +# +#sub send_fd { +# my ($self, $fd) = @_; +# local $_; +# +# print STDOUT while defined ($_ = <$fd>); +#} +# +## Should this perhaps throw an exception? +## sub internal_redirect {} +## sub internal_redirect_handler {} +# +## Do something with ErrorDocument? +## sub custom_response {} +# +## I think we've made this essentially the same thing. +#BEGIN { +# local $^W; +# *send_cgi_header = \&send_http_header; +#} +# +## Does CGI support logging? +## sub log_reason {} +## sub log_error {} +#sub warn { +# shift; +# print STDERR @_, "\n"; +#} +# +#sub params { +# my $self = shift; +# return _cgi_request_args($self->query, $self->query->request_method); +#} +# +#sub _cgi_request_args{ +# my ($q, $method) = @_; +# +# my %args; +# +# # Checking that there really is no query string when the method is +# # not POST is important because otherwise ->url_param returns a +# # parameter named 'keywords' with a value of () (empty array). +# # This is apparently a feature related to queries or +# # something (see the CGI.pm) docs. It makes my head hurt. - dave +# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); +# +# foreach my $key ( map { $q->$_() } @methods ) { +# next if exists $args{$key}; +# my @values = map { $q->$_($key) } @methods; +# $args{$key} = @values == 1 ? $values[0] : \@values; +# } +# +# return wantarray ? %args : \%args; +#} +# +# +############################################################ +#package WebGUI::Session::Request::FakeTable; +## Analogous to Apache::Table. +#use strict; +#use warnings; +# +#sub new { +# my $class = shift; +# my $self = {}; +# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; +# %$self = @_ if @_; +# return bless $self, ref $class || $class; +#} +# +#sub set { +# my ($self, $header, $value) = @_; +# defined $value ? $self->{$header} = $value : delete $self->{$header}; +#} +# +#sub unset { +# my $self = shift; +# delete $self->{shift()}; +#} +# +#sub add { +# tied(%{shift()})->add(@_); +#} +# +#sub clear { +# %{shift()} = (); +#} +# +#sub get { +# tied(%{shift()})->get(@_); +#} +# +#sub merge { +# my ($self, $key, $value) = @_; +# if (defined $self->{$key}) { +# $self->{$key} .= ',' . $value; +# } else { +# $self->{$key} = "$value"; +# } +#} +# +#sub do { +# my ($self, $code) = @_; +# while (my ($k, $val) = each %$self) { +# for my $v (ref $val ? @$val : $val) { +# return unless $code->($k => $v); +# } +# } +#} +# +############################################################ +#package WebGUI::Session::Request::FakeTableHash; +## Used by WebGUI::Session::Request::FakeTable. +#use strict; +#use warnings; +# +#sub TIEHASH { +# my $class = shift; +# return bless {}, ref $class || $class; +#} +# +#sub _canonical_key { +# my $key = lc shift; +# # CGI really wants a - before each header +# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; +#} +# +#sub STORE { +# my ($self, $key, $value) = @_; +# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; +#} +# +#sub add { +# my ($self, $key) = (shift, shift); +# return unless defined $_[0]; +# my $value = ref $_[0] ? "$_[0]" : $_[0]; +# my $ckey = _canonical_key $key; +# if (exists $self->{$ckey}) { +# if (ref $self->{$ckey}[1]) { +# push @{$self->{$ckey}[1]}, $value; +# } else { +# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; +# } +# } else { +# $self->{$ckey} = [ $key => $value ]; +# } +#} +# +#sub DELETE { +# my ($self, $key) = @_; +# my $ret = delete $self->{_canonical_key $key}; +# return $ret->[1]; +#} +# +#sub FETCH { +# my ($self, $key) = @_; +# # Grab the values first so that we don't autovivicate the key. +# my $val = $self->{_canonical_key $key} or return; +# if (my $ref = ref $val->[1]) { +# return unless $val->[1][0]; +# # Return the first value only. +# return $val->[1][0]; +# } +# return $val->[1]; +#} +# +#sub get { +# my ($self, $key) = @_; +# my $ckey = _canonical_key $key; +# return unless exists $self->{$ckey}; +# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; +# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; +#} +# +#sub CLEAR { +# %{shift()} = (); +#} +# +#sub EXISTS { +# my ($self, $key)= @_; +# return exists $self->{_canonical_key $key}; +#} +# +#sub FIRSTKEY { +# my $self = shift; +# # Reset perl's iterator. +# keys %$self; +# # Get the first key via perl's iterator. +# my $first_key = each %$self; +# return undef unless defined $first_key; +# return $self->{$first_key}[0]; +#} +# +#sub NEXTKEY { +# my ($self, $nextkey) = @_; +# # Get the next key via perl's iterator. +# my $next_key = each %$self; +# return undef unless defined $next_key; +# return $self->{$next_key}[0]; +#} +# +#sub cgi_headers { +# my $self = shift; +# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; +#} +# +#sub _map_header_key_to_cgi_key { +# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; +#} 1; diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 14a2d8fd4..d2cb3f799 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -62,6 +62,55 @@ to the user, instead of displaying the Page Not Found page. sub handler { my ($request, $server, $config) = @_; + + if ($request->isa('Plack::Request')) { +# my $session = $request->pnotes('wgSession'); +# unless (defined $session) { +# my $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); +# } + my $env = $request->env; + my $session = WebGUI::Session->open($env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'}, $request); + WEBGUI_FATAL: 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; + return [ 200, [ 'Content-type' => 'text/html' ], [ 'Jah' ] ]; + } + $request->push_handlers(PerlResponseHandler => sub { my $session = $request->pnotes('wgSession'); unless (defined $session) { From dc60102f8d26ea28364643a77adb74f94e9294d5 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 22:02:06 +1100 Subject: [PATCH 03/92] Added WebGUI::Session::Plack --- lib/WebGUI.pm | 35 ++- lib/WebGUI/Session.pm | 8 +- lib/WebGUI/Session/Plack.pm | 553 ++++++++++++++++++++++++++++++++++ lib/WebGUI/Session/Request.pm | 522 +------------------------------- lib/WebGUI/URL/Content.pm | 48 --- 5 files changed, 600 insertions(+), 566 deletions(-) create mode 100644 lib/WebGUI/Session/Plack.pm diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 5da74d210..4d841943b 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -208,27 +208,48 @@ sub handler { } sub handle_psgi { - my $env = shift; - my $request = WebGUI::Session::Request->new( env => $env ); + my $env = shift; # instead of an Apache2::Request object + require WebGUI::Session::Plack; + my $plack = WebGUI::Session::Plack->new( env => $env ); + my $server = $plack->server; my $config = WebGUI::Config->new( $env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'} ); - my $server; my $error = ""; - my $matchUri = $request->plack->request_uri; + my $matchUri = $plack->uri; my $gateway = $config->get("gateway"); $matchUri =~ s{^$gateway}{/}; - - # We should probably ditch URL Handlers altogether in favour of Plack::Middleware + +# # handle basic auth +# my $auth = $plack->headers_in->{'Authorization'}; +# if ($auth =~ m/^Basic/) { # machine oriented +# # Get username and password from Apache and hand over to authen +# $auth =~ s/Basic //; +# authen($plack, split(":", MIME::Base64::decode_base64($auth), 2), $config); +# } +# else { # realm oriented +# $plack->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($plack, undef, undef, $config)}); +# } + + + # url handlers + # TODO: We should probably ditch URL Handlers altogether in favour of Plack::Middleware 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 ] ) }; + my $output = eval { WebGUI::Pluggable::run( $handler->{$regex}, "handler", [ $plack, $server, $config ] ) }; if ($@) { $error = $@; last; } +# else { +# $gotMatch = 1; +# if ($output ne Apache2::Const::DECLINED) { +# return $output; +# } +# } return $output if $output; } } +# return Apache2::Const::DECLINED if ($gotMatch); # can't handle the url due to error or misconfiguration return [ diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 7d3c5d1fb..82ed7a84c 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -29,7 +29,6 @@ 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; @@ -464,7 +463,12 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; + + # This does our Plack TODO logging + # $self->{_request} = $request if (defined $request); + use WebGUI::Session::Request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; + my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm new file mode 100644 index 000000000..71ca347d9 --- /dev/null +++ b/lib/WebGUI/Session/Plack.pm @@ -0,0 +1,553 @@ +package WebGUI::Session::Plack; + +use strict; +use warnings; + +=head1 DESCRIPTION + +This class is used instead of WebGUI::Session::Request when wg is started via plackup + +=cut + +sub new { + my $class = shift; + my %p = @_; + + # 'require' rather than 'use' so that non-plebgui doesn't freak out + require Plack::Request; + require Plack::Response; + + my $request = Plack::Request->new( $p{env} ); + my $response = $request->new_response; + + bless { + %p, + pnotes => {}, + request => $request, + response => $response, + server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + }, $class; +} + +sub session { $_[0]{session} } +sub env { $_[0]{env} } +sub request { $_[0]{request} } +sub response { $_[0]{response} } +sub server { $_[0]{server} } + +our $AUTOLOAD; + +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + + warn "!!plack->$what(@_)"; +} + +sub uri { shift->request->request_uri(@_) } +sub headers_in { shift->request->headers(@_) } + +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 push_handlers { + my $self = shift; + my ($x, $sub) = @_; + warn "push_handlers on $x"; + return $sub->(); +} +# +#sub headers_in { +# my $self = shift; +# return unless $self->plack; +# return $self->plack->headers(@_); +#} + +package WebGUI::Session::Plack::Server; + +use strict; +use warnings; + +sub new { + my $class = shift; + bless { @_ }, $class; +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + + warn "!!server->$what(@_)"; + return; +} + +# -- + +## CGI request are _always_ main, and there is never a previous or a next +## internal request. +#sub main {} +#sub prev {} +#sub next {} +#sub is_main {1} +#sub is_initial_req {1} +# +## What to do with this? +## sub allowed {} +# +#sub method { +# $_[0]->query->request_method; +#} +# +## There mut be a mapping for this. +## sub method_number {} +# +## Can CGI.pm tell us this? +## sub bytes_sent {0} +# +## The request line sent by the client." Poached from Apache::Emulator. +#sub the_request { +# my $self = shift; +# $self->{the_request} ||= join ' ', $self->method, +# ( $self->{query}->query_string +# ? $self->uri . '?' . $self->{query}->query_string +# : $self->uri ), +# $self->{query}->server_protocol; +#} +# +## Is CGI ever a proxy request? +## sub proxy_req {} +# +#sub header_only { $_[0]->method eq 'HEAD' } +# +#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } +# +#sub hostname { $_[0]->{query}->server_name } +# +## CGI says "use this when using virtual hosts". It falls back to +## CGI->server_port. +#sub get_server_port { $_[0]->{query}->virtual_port } +# +## Fake it by just giving the current time. +#sub request_time { time } +# +#sub uri { +# my $self = shift; +# +# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; +#} +# +## Is this available in CGI? +## sub filename {} +# +## "The $r->location method will return the path of the +## section from which the current "Perl*Handler" +## is being called." This is irrelevant, I think. +## sub location {} +# +#sub path_info { $_[0]->{query}->path_info } +# +#sub args { +# my $self = shift; +# if (@_) { +# # Assign args here. +# } +# return $self->{query}->Vars unless wantarray; +# # Do more here to return key => arg values. +#} +# +#sub headers_in { +# my $self = shift; +# +# # Create the headers table if necessary. Decided how to build it based on +# # information here: +# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 +# # +# # Try to get as much info as possible from CGI.pm, which has +# # workarounds for things like the IIS PATH_INFO bug. +# # +# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new +# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. +# 'Content-Length' => $ENV{CONTENT_LENGTH}, +# 'Content-Type' => +# ( $self->{query}->can('content_type') ? +# $self->{query}->content_type : +# $ENV{CONTENT_TYPE} +# ), +# # Convert HTTP environment variables back into their header names. +# map { +# my $k = ucfirst lc; +# $k =~ s/_(.)/-\u$1/g; +# ( $k => $self->{query}->http($_) ) +# } grep { s/^HTTP_// } keys %ENV +# ); +# +# +# # Give 'em the hash list of the hash table. +# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; +#} +# +#sub header_in { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_in; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +# +## The $r->content method will return the entity body +## read from the client, but only if the request content +## type is "application/x-www-form-urlencoded". When +## called in a scalar context, the entire string is +## returned. When called in a list context, a list of +## parsed key => value pairs are returned. *NOTE*: you +## can only ask for this once, as the entire body is read +## from the client. +## Not sure what to do with this one. +## sub content {} +# +## I think this may be irrelevant under CGI. +## sub read {} +# +## Use LWP? +#sub get_remote_host {} +#sub get_remote_logname {} +# +#sub http_header { +# my $self = shift; +# my $h = $self->headers_out; +# my $e = $self->err_headers_out; +# my $method = exists $h->{Location} || exists $e->{Location} ? +# 'redirect' : 'header'; +# return $self->query->$method(tied(%$h)->cgi_headers, +# tied(%$e)->cgi_headers); +#} +# +#sub send_http_header { +# my $self = shift; +# +# return if $self->http_header_sent; +# +# print STDOUT $self->http_header; +# +# $self->{http_header_sent} = 1; +#} +# +#sub http_header_sent { shift->{http_header_sent} } +# +## How do we know this under CGI? +## sub get_basic_auth_pw {} +## sub note_basic_auth_failure {} +# +## I think that this just has to be empty. +#sub handler {} +# +#sub notes { +# my ($self, $key) = (shift, shift); +# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; +# return wantarray ? %{$self->{notes}} : $self->{notes} +# unless defined $key; +# return $self->{notes}{$key} = "$_[0]" if @_; +# return $self->{notes}{$key}; +#} +# +#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 subprocess_env { +# my ($self, $key) = (shift, shift); +# unless (defined $key) { +# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); +# return wantarray ? %{$self->{subprocess_env}} : +# $self->{subprocess_env}; +# +# } +# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); +# return $self->{subprocess_env}{$key} = "$_[0]" if @_; +# return $self->{subprocess_env}{$key}; +#} +# +#sub content_type { +# shift->header_out('Content-Type', @_); +#} +# +#sub content_encoding { +# shift->header_out('Content-Encoding', @_); +#} +# +#sub content_languages { +# my ($self, $langs) = @_; +# return unless $langs; +# my $h = shift->headers_out; +# for my $l (@$langs) { +# $h->add('Content-Language', $l); +# } +#} +# +#sub status { +# shift->header_out('Status', @_); +#} +# +#sub status_line { +# # What to do here? Should it be managed differently than status? +# my $self = shift; +# if (@_) { +# my $status = shift =~ /^(\d+)/; +# return $self->header_out('Status', $status); +# } +# return $self->header_out('Status'); +#} +# +#sub headers_out { +# my $self = shift; +# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; +#} +# +#sub header_out { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_out; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +#sub err_headers_out { +# my $self = shift; +# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; +#} +# +#sub err_header_out { +# my ($self, $err_header) = (shift, shift); +# my $h = $self->err_headers_out; +# return @_ ? $h->set($err_header, shift) : $h->get($err_header); +#} +# +#sub no_cache { +# my $self = shift; +# $self->header_out(Pragma => 'no-cache'); +# $self->header_out('Cache-Control' => 'no-cache'); +#} +# +#sub print { +# shift; +# print @_; +#} +# +#sub send_fd { +# my ($self, $fd) = @_; +# local $_; +# +# print STDOUT while defined ($_ = <$fd>); +#} +# +## Should this perhaps throw an exception? +## sub internal_redirect {} +## sub internal_redirect_handler {} +# +## Do something with ErrorDocument? +## sub custom_response {} +# +## I think we've made this essentially the same thing. +#BEGIN { +# local $^W; +# *send_cgi_header = \&send_http_header; +#} +# +## Does CGI support logging? +## sub log_reason {} +## sub log_error {} +#sub warn { +# shift; +# print STDERR @_, "\n"; +#} +# +#sub params { +# my $self = shift; +# return _cgi_request_args($self->query, $self->query->request_method); +#} +# +#sub _cgi_request_args{ +# my ($q, $method) = @_; +# +# my %args; +# +# # Checking that there really is no query string when the method is +# # not POST is important because otherwise ->url_param returns a +# # parameter named 'keywords' with a value of () (empty array). +# # This is apparently a feature related to queries or +# # something (see the CGI.pm) docs. It makes my head hurt. - dave +# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); +# +# foreach my $key ( map { $q->$_() } @methods ) { +# next if exists $args{$key}; +# my @values = map { $q->$_($key) } @methods; +# $args{$key} = @values == 1 ? $values[0] : \@values; +# } +# +# return wantarray ? %args : \%args; +#} +# +# +############################################################ +#package WebGUI::Session::Request::FakeTable; +## Analogous to Apache::Table. +#use strict; +#use warnings; +# +#sub new { +# my $class = shift; +# my $self = {}; +# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; +# %$self = @_ if @_; +# return bless $self, ref $class || $class; +#} +# +#sub set { +# my ($self, $header, $value) = @_; +# defined $value ? $self->{$header} = $value : delete $self->{$header}; +#} +# +#sub unset { +# my $self = shift; +# delete $self->{shift()}; +#} +# +#sub add { +# tied(%{shift()})->add(@_); +#} +# +#sub clear { +# %{shift()} = (); +#} +# +#sub get { +# tied(%{shift()})->get(@_); +#} +# +#sub merge { +# my ($self, $key, $value) = @_; +# if (defined $self->{$key}) { +# $self->{$key} .= ',' . $value; +# } else { +# $self->{$key} = "$value"; +# } +#} +# +#sub do { +# my ($self, $code) = @_; +# while (my ($k, $val) = each %$self) { +# for my $v (ref $val ? @$val : $val) { +# return unless $code->($k => $v); +# } +# } +#} +# +############################################################ +#package WebGUI::Session::Request::FakeTableHash; +## Used by WebGUI::Session::Request::FakeTable. +#use strict; +#use warnings; +# +#sub TIEHASH { +# my $class = shift; +# return bless {}, ref $class || $class; +#} +# +#sub _canonical_key { +# my $key = lc shift; +# # CGI really wants a - before each header +# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; +#} +# +#sub STORE { +# my ($self, $key, $value) = @_; +# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; +#} +# +#sub add { +# my ($self, $key) = (shift, shift); +# return unless defined $_[0]; +# my $value = ref $_[0] ? "$_[0]" : $_[0]; +# my $ckey = _canonical_key $key; +# if (exists $self->{$ckey}) { +# if (ref $self->{$ckey}[1]) { +# push @{$self->{$ckey}[1]}, $value; +# } else { +# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; +# } +# } else { +# $self->{$ckey} = [ $key => $value ]; +# } +#} +# +#sub DELETE { +# my ($self, $key) = @_; +# my $ret = delete $self->{_canonical_key $key}; +# return $ret->[1]; +#} +# +#sub FETCH { +# my ($self, $key) = @_; +# # Grab the values first so that we don't autovivicate the key. +# my $val = $self->{_canonical_key $key} or return; +# if (my $ref = ref $val->[1]) { +# return unless $val->[1][0]; +# # Return the first value only. +# return $val->[1][0]; +# } +# return $val->[1]; +#} +# +#sub get { +# my ($self, $key) = @_; +# my $ckey = _canonical_key $key; +# return unless exists $self->{$ckey}; +# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; +# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; +#} +# +#sub CLEAR { +# %{shift()} = (); +#} +# +#sub EXISTS { +# my ($self, $key)= @_; +# return exists $self->{_canonical_key $key}; +#} +# +#sub FIRSTKEY { +# my $self = shift; +# # Reset perl's iterator. +# keys %$self; +# # Get the first key via perl's iterator. +# my $first_key = each %$self; +# return undef unless defined $first_key; +# return $self->{$first_key}[0]; +#} +# +#sub NEXTKEY { +# my ($self, $nextkey) = @_; +# # Get the next key via perl's iterator. +# my $next_key = each %$self; +# return undef unless defined $next_key; +# return $self->{$next_key}[0]; +#} +# +#sub cgi_headers { +# my $self = shift; +# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; +#} +# +#sub _map_header_key_to_cgi_key { +# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; +#} + +1; diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm index e988a96d7..88ae0835d 100644 --- a/lib/WebGUI/Session/Request.pm +++ b/lib/WebGUI/Session/Request.pm @@ -1,536 +1,40 @@ package WebGUI::Session::Request; -# We need to define an Apache package or we might get strange errors -# like "Can't locate package Apache for -# @WebGUI::Session::Request::ISA". We do the BEGIN/eval thing so that -# the CPAN indexer doesn't pick it up, which would be ugly. -#BEGIN { eval "package Apache" } -@WebGUI::Session::Request::ISA = qw(Apache); - -# Analogous to Apache request object $r (but not an actual Apache subclass) -# In the future we'll probably want to switch this to Apache::Fake or similar - use strict; use warnings; -use CGI; + +=head1 DESCRIPTION + +This class wraps calls to $session->request and logs them so that we know +what is left to do to finish Plack support + +=cut sub new { my $class = shift; - my %p = @_; - - my $self = bless { - %p, - - # query => $p{cgi} || CGI->new, - # headers_out => WebGUI::Session::Request::FakeTable->new, - # err_headers_out => WebGUI::Session::Request::FakeTable->new, - pnotes => {}, - }, $class; - - if ( $p{env} ) { - require Plack::Request; - require Plack::Response; - $self->{plack} = Plack::Request->new( $p{env} ); - } - - return $self; + bless { @_ }, $class; } -sub session { $_[0]{session} } -sub env { $_[0]{env} } -sub r { $_[0]{r} } -sub plack { $_[0]{plack} } - our $AUTOLOAD; - sub AUTOLOAD { my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - my $r = $self->r; + my $r = $self->{r}; + my $session = $self->{session}; if ( !$r ) { - $self->log("!!request->$what(@_) but r not defined"); + $session->log->error("!!request->$what(@_) but r not defined"); return; } if ( $what eq 'print' ) { - $self->log("!!request->$what(print--chomped)"); + $session->log->error("!!request->$what(print--chomped)"); } else { - $self->log("!!request->$what(@_)"); + $session->log->error("!!request->$what(@_)"); } return $r->$what(@_); } -sub log { - my $self = shift; - if ( $self->session ) { - $self->session->log->error(shift); - } - else { - warn shift; - } -} - -## CGI request are _always_ main, and there is never a previous or a next -## internal request. -#sub main {} -#sub prev {} -#sub next {} -#sub is_main {1} -#sub is_initial_req {1} -# -## What to do with this? -## sub allowed {} -# -#sub method { -# $_[0]->query->request_method; -#} -# -## There mut be a mapping for this. -## sub method_number {} -# -## Can CGI.pm tell us this? -## sub bytes_sent {0} -# -## The request line sent by the client." Poached from Apache::Emulator. -#sub the_request { -# my $self = shift; -# $self->{the_request} ||= join ' ', $self->method, -# ( $self->{query}->query_string -# ? $self->uri . '?' . $self->{query}->query_string -# : $self->uri ), -# $self->{query}->server_protocol; -#} -# -## Is CGI ever a proxy request? -## sub proxy_req {} -# -#sub header_only { $_[0]->method eq 'HEAD' } -# -#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } -# -#sub hostname { $_[0]->{query}->server_name } -# -## CGI says "use this when using virtual hosts". It falls back to -## CGI->server_port. -#sub get_server_port { $_[0]->{query}->virtual_port } -# -## Fake it by just giving the current time. -#sub request_time { time } -# -#sub uri { -# my $self = shift; -# -# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; -#} -# -## Is this available in CGI? -## sub filename {} -# -## "The $r->location method will return the path of the -## section from which the current "Perl*Handler" -## is being called." This is irrelevant, I think. -## sub location {} -# -#sub path_info { $_[0]->{query}->path_info } -# -#sub args { -# my $self = shift; -# if (@_) { -# # Assign args here. -# } -# return $self->{query}->Vars unless wantarray; -# # Do more here to return key => arg values. -#} -# -#sub headers_in { -# my $self = shift; -# -# # Create the headers table if necessary. Decided how to build it based on -# # information here: -# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 -# # -# # Try to get as much info as possible from CGI.pm, which has -# # workarounds for things like the IIS PATH_INFO bug. -# # -# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new -# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. -# 'Content-Length' => $ENV{CONTENT_LENGTH}, -# 'Content-Type' => -# ( $self->{query}->can('content_type') ? -# $self->{query}->content_type : -# $ENV{CONTENT_TYPE} -# ), -# # Convert HTTP environment variables back into their header names. -# map { -# my $k = ucfirst lc; -# $k =~ s/_(.)/-\u$1/g; -# ( $k => $self->{query}->http($_) ) -# } grep { s/^HTTP_// } keys %ENV -# ); -# -# -# # Give 'em the hash list of the hash table. -# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; -#} -# -#sub header_in { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_in; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -# -## The $r->content method will return the entity body -## read from the client, but only if the request content -## type is "application/x-www-form-urlencoded". When -## called in a scalar context, the entire string is -## returned. When called in a list context, a list of -## parsed key => value pairs are returned. *NOTE*: you -## can only ask for this once, as the entire body is read -## from the client. -## Not sure what to do with this one. -## sub content {} -# -## I think this may be irrelevant under CGI. -## sub read {} -# -## Use LWP? -#sub get_remote_host {} -#sub get_remote_logname {} -# -#sub http_header { -# my $self = shift; -# my $h = $self->headers_out; -# my $e = $self->err_headers_out; -# my $method = exists $h->{Location} || exists $e->{Location} ? -# 'redirect' : 'header'; -# return $self->query->$method(tied(%$h)->cgi_headers, -# tied(%$e)->cgi_headers); -#} -# -#sub send_http_header { -# my $self = shift; -# -# return if $self->http_header_sent; -# -# print STDOUT $self->http_header; -# -# $self->{http_header_sent} = 1; -#} -# -#sub http_header_sent { shift->{http_header_sent} } -# -## How do we know this under CGI? -## sub get_basic_auth_pw {} -## sub note_basic_auth_failure {} -# -## I think that this just has to be empty. -#sub handler {} -# -#sub notes { -# my ($self, $key) = (shift, shift); -# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; -# return wantarray ? %{$self->{notes}} : $self->{notes} -# unless defined $key; -# return $self->{notes}{$key} = "$_[0]" if @_; -# return $self->{notes}{$key}; -#} -# -#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 subprocess_env { -# my ($self, $key) = (shift, shift); -# unless (defined $key) { -# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); -# return wantarray ? %{$self->{subprocess_env}} : -# $self->{subprocess_env}; -# -# } -# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); -# return $self->{subprocess_env}{$key} = "$_[0]" if @_; -# return $self->{subprocess_env}{$key}; -#} -# -#sub content_type { -# shift->header_out('Content-Type', @_); -#} -# -#sub content_encoding { -# shift->header_out('Content-Encoding', @_); -#} -# -#sub content_languages { -# my ($self, $langs) = @_; -# return unless $langs; -# my $h = shift->headers_out; -# for my $l (@$langs) { -# $h->add('Content-Language', $l); -# } -#} -# -#sub status { -# shift->header_out('Status', @_); -#} -# -#sub status_line { -# # What to do here? Should it be managed differently than status? -# my $self = shift; -# if (@_) { -# my $status = shift =~ /^(\d+)/; -# return $self->header_out('Status', $status); -# } -# return $self->header_out('Status'); -#} -# -#sub headers_out { -# my $self = shift; -# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; -#} -# -#sub header_out { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_out; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -#sub err_headers_out { -# my $self = shift; -# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; -#} -# -#sub err_header_out { -# my ($self, $err_header) = (shift, shift); -# my $h = $self->err_headers_out; -# return @_ ? $h->set($err_header, shift) : $h->get($err_header); -#} -# -#sub no_cache { -# my $self = shift; -# $self->header_out(Pragma => 'no-cache'); -# $self->header_out('Cache-Control' => 'no-cache'); -#} -# -#sub print { -# shift; -# print @_; -#} -# -#sub send_fd { -# my ($self, $fd) = @_; -# local $_; -# -# print STDOUT while defined ($_ = <$fd>); -#} -# -## Should this perhaps throw an exception? -## sub internal_redirect {} -## sub internal_redirect_handler {} -# -## Do something with ErrorDocument? -## sub custom_response {} -# -## I think we've made this essentially the same thing. -#BEGIN { -# local $^W; -# *send_cgi_header = \&send_http_header; -#} -# -## Does CGI support logging? -## sub log_reason {} -## sub log_error {} -#sub warn { -# shift; -# print STDERR @_, "\n"; -#} -# -#sub params { -# my $self = shift; -# return _cgi_request_args($self->query, $self->query->request_method); -#} -# -#sub _cgi_request_args{ -# my ($q, $method) = @_; -# -# my %args; -# -# # Checking that there really is no query string when the method is -# # not POST is important because otherwise ->url_param returns a -# # parameter named 'keywords' with a value of () (empty array). -# # This is apparently a feature related to queries or -# # something (see the CGI.pm) docs. It makes my head hurt. - dave -# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); -# -# foreach my $key ( map { $q->$_() } @methods ) { -# next if exists $args{$key}; -# my @values = map { $q->$_($key) } @methods; -# $args{$key} = @values == 1 ? $values[0] : \@values; -# } -# -# return wantarray ? %args : \%args; -#} -# -# -############################################################ -#package WebGUI::Session::Request::FakeTable; -## Analogous to Apache::Table. -#use strict; -#use warnings; -# -#sub new { -# my $class = shift; -# my $self = {}; -# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; -# %$self = @_ if @_; -# return bless $self, ref $class || $class; -#} -# -#sub set { -# my ($self, $header, $value) = @_; -# defined $value ? $self->{$header} = $value : delete $self->{$header}; -#} -# -#sub unset { -# my $self = shift; -# delete $self->{shift()}; -#} -# -#sub add { -# tied(%{shift()})->add(@_); -#} -# -#sub clear { -# %{shift()} = (); -#} -# -#sub get { -# tied(%{shift()})->get(@_); -#} -# -#sub merge { -# my ($self, $key, $value) = @_; -# if (defined $self->{$key}) { -# $self->{$key} .= ',' . $value; -# } else { -# $self->{$key} = "$value"; -# } -#} -# -#sub do { -# my ($self, $code) = @_; -# while (my ($k, $val) = each %$self) { -# for my $v (ref $val ? @$val : $val) { -# return unless $code->($k => $v); -# } -# } -#} -# -############################################################ -#package WebGUI::Session::Request::FakeTableHash; -## Used by WebGUI::Session::Request::FakeTable. -#use strict; -#use warnings; -# -#sub TIEHASH { -# my $class = shift; -# return bless {}, ref $class || $class; -#} -# -#sub _canonical_key { -# my $key = lc shift; -# # CGI really wants a - before each header -# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; -#} -# -#sub STORE { -# my ($self, $key, $value) = @_; -# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; -#} -# -#sub add { -# my ($self, $key) = (shift, shift); -# return unless defined $_[0]; -# my $value = ref $_[0] ? "$_[0]" : $_[0]; -# my $ckey = _canonical_key $key; -# if (exists $self->{$ckey}) { -# if (ref $self->{$ckey}[1]) { -# push @{$self->{$ckey}[1]}, $value; -# } else { -# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; -# } -# } else { -# $self->{$ckey} = [ $key => $value ]; -# } -#} -# -#sub DELETE { -# my ($self, $key) = @_; -# my $ret = delete $self->{_canonical_key $key}; -# return $ret->[1]; -#} -# -#sub FETCH { -# my ($self, $key) = @_; -# # Grab the values first so that we don't autovivicate the key. -# my $val = $self->{_canonical_key $key} or return; -# if (my $ref = ref $val->[1]) { -# return unless $val->[1][0]; -# # Return the first value only. -# return $val->[1][0]; -# } -# return $val->[1]; -#} -# -#sub get { -# my ($self, $key) = @_; -# my $ckey = _canonical_key $key; -# return unless exists $self->{$ckey}; -# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; -# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; -#} -# -#sub CLEAR { -# %{shift()} = (); -#} -# -#sub EXISTS { -# my ($self, $key)= @_; -# return exists $self->{_canonical_key $key}; -#} -# -#sub FIRSTKEY { -# my $self = shift; -# # Reset perl's iterator. -# keys %$self; -# # Get the first key via perl's iterator. -# my $first_key = each %$self; -# return undef unless defined $first_key; -# return $self->{$first_key}[0]; -#} -# -#sub NEXTKEY { -# my ($self, $nextkey) = @_; -# # Get the next key via perl's iterator. -# my $next_key = each %$self; -# return undef unless defined $next_key; -# return $self->{$next_key}[0]; -#} -# -#sub cgi_headers { -# my $self = shift; -# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; -#} -# -#sub _map_header_key_to_cgi_key { -# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; -#} - 1; diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index d2cb3f799..5102946b8 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -63,54 +63,6 @@ to the user, instead of displaying the Page Not Found page. sub handler { my ($request, $server, $config) = @_; - if ($request->isa('Plack::Request')) { -# my $session = $request->pnotes('wgSession'); -# unless (defined $session) { -# my $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); -# } - my $env = $request->env; - my $session = WebGUI::Session->open($env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'}, $request); - WEBGUI_FATAL: 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; - return [ 200, [ 'Content-type' => 'text/html' ], [ 'Jah' ] ]; - } - $request->push_handlers(PerlResponseHandler => sub { my $session = $request->pnotes('wgSession'); unless (defined $session) { From da75a8b2075f6c638268aa20781f936fc279b31b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 22:11:01 +1100 Subject: [PATCH 04/92] checkpoint --- etc/dev.localhost.localdomain.psgi | 2 ++ lib/WebGUI/Session/Plack.pm | 11 ++++++++++- lib/WebGUI/Session/Request.pm | 4 ++-- lib/WebGUI/URL/Content.pm | 1 - 4 files changed, 14 insertions(+), 4 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 4e5dad288..4591416da 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -13,6 +13,8 @@ my $app = sub { my $env = shift; $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; + $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; + $env->{'wg.DIR_CONFIG.WebguiConfig'} = $env->{'wg.WEBGUI_CONFIG'}; WebGUI::handle_psgi($env); }; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 71ca347d9..49ab5f62e 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -2,6 +2,7 @@ package WebGUI::Session::Plack; use strict; use warnings; +use Carp; =head1 DESCRIPTION @@ -58,7 +59,7 @@ sub pnotes { sub push_handlers { my $self = shift; my ($x, $sub) = @_; - warn "push_handlers on $x"; + carp "push_handlers on $x"; return $sub->(); } # @@ -78,6 +79,8 @@ sub new { bless { @_ }, $class; } +sub env { shift->{env} } + our $AUTOLOAD; sub AUTOLOAD { my $self = shift; @@ -88,6 +91,12 @@ sub AUTOLOAD { return; } +sub dir_config { + my $self = shift; + my $c = shift; + return $self->env->{"wg.DIR_CONFIG.$c"}; +} + # -- ## CGI request are _always_ main, and there is never a previous or a next diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm index 88ae0835d..3c1cc87a3 100644 --- a/lib/WebGUI/Session/Request.pm +++ b/lib/WebGUI/Session/Request.pm @@ -5,8 +5,8 @@ use warnings; =head1 DESCRIPTION -This class wraps calls to $session->request and logs them so that we know -what is left to do to finish Plack support +This class wraps calls to $session->request and logs them as a cute way of seeing +what Apache2::* methods webgui is calling =cut diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 5102946b8..14a2d8fd4 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -62,7 +62,6 @@ to the user, instead of displaying the Page Not Found page. sub handler { my ($request, $server, $config) = @_; - $request->push_handlers(PerlResponseHandler => sub { my $session = $request->pnotes('wgSession'); unless (defined $session) { From d8e6256da849a83171500a0946fef135f9c9cf87 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 22:37:18 +1100 Subject: [PATCH 05/92] more minor progress --- lib/WebGUI/Session.pm | 13 +++++++++---- lib/WebGUI/Session/Http.pm | 4 ++++ lib/WebGUI/Session/Plack.pm | 6 ++++++ 3 files changed, 19 insertions(+), 4 deletions(-) diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 82ed7a84c..8441c089c 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -463,11 +463,16 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - - # This does our Plack TODO logging + # $self->{_request} = $request if (defined $request); - use WebGUI::Session::Request; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; + if ($request && $request->isa('WebGUI::Session::Plack')) { + # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can + $self->{_request} = $request; + } else { + # Use WebGUI::Session::Request to wrap Apache2::* calls + require WebGUI::Session::Request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); + } my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 67b65678d..d38b08303 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -92,6 +92,10 @@ Retrieves the cookies from the HTTP header and returns a hash reference containi sub getCookies { my $self = shift; if ($self->session->request) { + if ($self->session->request->isa('WebGUI::Session::Plack')) { + return $self->session->request->request->cookies; + } + # 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(); diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 49ab5f62e..cde6a74c9 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -48,6 +48,12 @@ sub AUTOLOAD { sub uri { shift->request->request_uri(@_) } sub headers_in { shift->request->headers(@_) } +sub param { shift->request->param(@_) } +sub params { shift->request->params(@_) } + +# TODO: I suppose this should do some sort of IO::Handle thing +my @body; +sub print { shift; push @body, @_ } sub pnotes { my ($self, $key) = (shift, shift); From e04b1ebc9de1b968ee9a1efd11aed60048448c85 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 11:44:10 +1100 Subject: [PATCH 06/92] text but no images --- lib/WebGUI.pm | 81 +++++++++++-------------------------- lib/WebGUI/Session/Http.pm | 10 +++++ lib/WebGUI/Session/Plack.pm | 74 ++++++++++++++++++++++++++++++--- 3 files changed, 101 insertions(+), 64 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 4d841943b..b39615f43 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -156,10 +156,15 @@ 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 $request = shift; # either apache request object or PSGI env hash + my $server; + if ($request->isa('WebGUI::Session::Plack')) { + $server = $request->server; + } else { + $request = Apache2::Request->new($request); + $server = Apache2::ServerUtil->server; #instantiate the server api + } 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($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object my $error = ""; my $matchUri = $request->uri; @@ -168,15 +173,15 @@ sub handler { 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)}); - } +# 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 @@ -208,55 +213,15 @@ sub handler { } sub handle_psgi { - my $env = shift; # instead of an Apache2::Request object + my $env = shift; require WebGUI::Session::Plack; - my $plack = WebGUI::Session::Plack->new( env => $env ); - my $server = $plack->server; - my $config = WebGUI::Config->new( $env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'} ); - my $error = ""; - my $matchUri = $plack->uri; - my $gateway = $config->get("gateway"); - $matchUri =~ s{^$gateway}{/}; + my $plack = WebGUI::Session::Plack->new( env => $env ); -# # handle basic auth -# my $auth = $plack->headers_in->{'Authorization'}; -# if ($auth =~ m/^Basic/) { # machine oriented -# # Get username and password from Apache and hand over to authen -# $auth =~ s/Basic //; -# authen($plack, split(":", MIME::Base64::decode_base64($auth), 2), $config); -# } -# else { # realm oriented -# $plack->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($plack, undef, undef, $config)}); -# } + # returns something like Apache2::Const::OK, which we ignore + my $ret = handler($plack); - - # url handlers - # TODO: We should probably ditch URL Handlers altogether in favour of Plack::Middleware - 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", [ $plack, $server, $config ] ) }; - if ($@) { - $error = $@; - last; - } -# else { -# $gotMatch = 1; -# if ($output ne Apache2::Const::DECLINED) { -# return $output; -# } -# } - return $output if $output; - } - } -# return Apache2::Const::DECLINED if ($gotMatch); - - # can't handle the url due to error or misconfiguration - return [ - 500, - [ 'Content-Type' => 'text/html' ], - ["This server is unable to handle the url '$matchUri' that you requested. $error"] - ]; + # let Plack::Response do its thing + return $plack->finalize; } 1; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index d38b08303..2fbb01af5 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -389,6 +389,16 @@ sub setCookie { $ttl = (defined $ttl ? $ttl : '+10y'); if ($self->session->request) { + if ($self->session->request->isa('WebGUI::Session::Plack')) { + $self->session->request->response->cookies->{$name} = { + value => $value, + path => '/', + expires => $ttl ne 'session' ? $ttl : undef, + domain => $domain, + }; + return; + } + require Apache2::Cookie; my $cookie = Apache2::Cookie->new($self->session->request, -name=>$name, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index cde6a74c9..2cd5906fc 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -21,13 +21,17 @@ sub new { my $request = Plack::Request->new( $p{env} ); my $response = $request->new_response; - bless { + my $self = bless { %p, pnotes => {}, request => $request, response => $response, server => WebGUI::Session::Plack::Server->new( env => $p{env} ), }, $class; + + $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( plack => $self ); + + return $self; } sub session { $_[0]{session} } @@ -43,18 +47,28 @@ sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - warn "!!plack->$what(@_)"; + carp "!!plack->$what(@_)"; } sub uri { shift->request->request_uri(@_) } -sub headers_in { shift->request->headers(@_) } sub param { shift->request->param(@_) } sub params { shift->request->params(@_) } +sub headers_in { shift->request->headers(@_) } +sub headers_out { shift->{headers_out} } +sub protocol { shift->request->protocol(@_) } +sub status { shift->response->status(@_) } +sub status_line {} # TODO: I suppose this should do some sort of IO::Handle thing my @body; sub print { shift; push @body, @_ } +sub dir_config { + my $self = shift; + my $c = shift; + return $self->env->{"wg.DIR_CONFIG.$c"}; +} + sub pnotes { my ($self, $key) = (shift, shift); return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key; @@ -62,12 +76,36 @@ sub pnotes { 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) = @_; - carp "push_handlers on $x"; - return $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; + $self->response->body(\@body); + return $self->response->finalize; +} + +sub content_type { shift->response->content_type(@_) } + # #sub headers_in { # my $self = shift; @@ -79,6 +117,7 @@ package WebGUI::Session::Plack::Server; use strict; use warnings; +use Carp; sub new { my $class = shift; @@ -93,7 +132,7 @@ sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - warn "!!server->$what(@_)"; + carp "!!server->$what(@_)"; return; } @@ -103,6 +142,29 @@ sub dir_config { return $self->env->{"wg.DIR_CONFIG.$c"}; } +package WebGUI::Session::Plack::HeadersOut; + +use strict; +use warnings; +use Carp; + +sub new { + my $class = shift; + bless { @_ }, $class; +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + + carp "!!headers_out->$what(@_)"; + return; +} + +sub set { shift->{plack}->response->headers->header(@_) } + # -- ## CGI request are _always_ main, and there is never a previous or a next From 5982b2728c8d3233d198c7cc89221c03c5e76e7b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 12:11:22 +1100 Subject: [PATCH 07/92] Caching is breaking something --- etc/dev.localhost.localdomain.psgi | 35 +++++++++++++++++------------- lib/WebGUI.pm | 29 +++++++++++++++---------- lib/WebGUI/Session/Plack.pm | 15 +++++++++++-- 3 files changed, 51 insertions(+), 28 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 4591416da..febb7bdbd 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,8 +1,9 @@ BEGIN { + # This is just a temporary hack - our $WEBGUI_ROOT = '/data/WebGUI'; + our $WEBGUI_ROOT = '/data/WebGUI'; our $WEBGUI_DOMAINS = '/data/domains'; - our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; + our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; } use local::lib $WEBGUI_ROOT; use WebGUI; @@ -11,26 +12,30 @@ use Plack::Builder; my $app = sub { my $env = shift; - $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; - $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; - $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; + $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; + $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; + $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; $env->{'wg.DIR_CONFIG.WebguiConfig'} = $env->{'wg.WEBGUI_CONFIG'}; WebGUI::handle_psgi($env); }; # Apply some Middleware builder { + # /extras - enable Plack::Middleware::Static - path => qr{^/extras/}, root => "$WEBGUI_ROOT/www/"; - + enable Plack::Middleware::Static + path => qr{^/extras/}, + root => "$WEBGUI_ROOT/www/"; + # /uploads (ignore .wgaccess for now..) - enable Plack::Middleware::Static - path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; - + enable Plack::Middleware::Static + path => qr{^/uploads/}, + root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; + enable Plack::Middleware::XFramework framework => 'WebGUI'; - - enable Plack::Middleware::AccessLog format => "combined"; - + + # Already enabled by plackup script + # enable Plack::Middleware::AccessLog format => "combined"; + $app; -} \ No newline at end of file +} diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index b39615f43..f60f377de 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -78,8 +78,13 @@ A reference to a WebGUI::Config object. One will be created if it isn't specifie sub authen { my ($request, $username, $password, $config) = @_; - $request = Apache2::Request->new($request); - my $server = Apache2::ServerUtil->server; + my $server; + if ($request->isa('WebGUI::Session::Plack')) { + $server = $request->server; + } else { + $request = Apache2::Request->new($request); + $server = Apache2::ServerUtil->server; #instantiate the server api + } my $status = Apache2::Const::OK; # set username and password if it's an auth handler @@ -173,15 +178,15 @@ sub handler { 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)}); -# } + 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 @@ -212,6 +217,8 @@ sub handler { return Apache2::Const::DECLINED; } + + sub handle_psgi { my $env = shift; require WebGUI::Session::Plack; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 2cd5906fc..0ef9a90c5 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -19,7 +19,7 @@ sub new { require Plack::Response; my $request = Plack::Request->new( $p{env} ); - my $response = $request->new_response; + my $response = $request->new_response(200); my $self = bless { %p, @@ -59,10 +59,17 @@ sub protocol { shift->request->protocol(@_) } sub status { shift->response->status(@_) } sub status_line {} +sub auth_type { + # should we support this? +} + # TODO: I suppose this should do some sort of IO::Handle thing my @body; sub print { shift; push @body, @_ } +my $sendfile; +sub sendfile { shift; $sendfile = shift; } + sub dir_config { my $self = shift; my $c = shift; @@ -100,7 +107,11 @@ sub push_handlers { sub finalize { my $self = shift; - $self->response->body(\@body); + if ($sendfile && open my $fh, '<', $sendfile) { + $self->response->body( $fh ); + } else { + $self->response->body( $sendfile || \@body); + } return $self->response->finalize; } From 484760bef0163e5f0048678457461caa5eb168aa Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 18:54:54 +1100 Subject: [PATCH 08/92] she works! --- etc/dev.localhost.localdomain.psgi | 14 +- lib/WebGUI/Session.pm | 16 +- lib/WebGUI/Session/Http.pm | 4 +- lib/WebGUI/Session/Plack.pm | 552 +++-------------------------- 4 files changed, 60 insertions(+), 526 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index febb7bdbd..df9d00c61 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -7,7 +7,7 @@ BEGIN { } use local::lib $WEBGUI_ROOT; use WebGUI; -use Plack::Middleware qw( Static XFramework AccessLog ); +use Plack::Middleware; use Plack::Builder; my $app = sub { @@ -23,19 +23,21 @@ my $app = sub { builder { # /extras - enable Plack::Middleware::Static + add 'Plack::Middleware::Static', path => qr{^/extras/}, root => "$WEBGUI_ROOT/www/"; # /uploads (ignore .wgaccess for now..) - enable Plack::Middleware::Static + add 'Plack::Middleware::Static', path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; - enable Plack::Middleware::XFramework framework => 'WebGUI'; + add 'Plack::Middleware::XFramework', + framework => 'WebGUI'; # Already enabled by plackup script - # enable Plack::Middleware::AccessLog format => "combined"; + # add 'Plack::Middleware::AccessLog', + # format => "combined"; $app; -} +} \ No newline at end of file diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 8441c089c..1cc1d497b 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -465,13 +465,15 @@ sub open { bless $self , $class; # $self->{_request} = $request if (defined $request); - if ($request && $request->isa('WebGUI::Session::Plack')) { - # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can - $self->{_request} = $request; - } else { - # Use WebGUI::Session::Request to wrap Apache2::* calls - require WebGUI::Session::Request; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); + if ($request) { + if ($request->isa('WebGUI::Session::Plack')) { + # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can + $self->{_request} = $request; + } else { + # Use WebGUI::Session::Request to wrap Apache2::* calls + require WebGUI::Session::Request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); + } } my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 2fbb01af5..473d55835 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -93,7 +93,7 @@ sub getCookies { my $self = shift; if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->request->cookies; + return $self->session->request->request_cookies; } # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) @@ -390,7 +390,7 @@ sub setCookie { if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - $self->session->request->response->cookies->{$name} = { + $self->session->request->response_cookies->{$name} = { value => $value, path => '/', expires => $ttl ne 'session' ? $ttl : undef, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 0ef9a90c5..2a123207e 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -11,13 +11,10 @@ This class is used instead of WebGUI::Session::Request when wg is started via pl =cut sub new { - my $class = shift; - my %p = @_; + my ($class, %p) = @_; # 'require' rather than 'use' so that non-plebgui doesn't freak out require Plack::Request; - require Plack::Response; - my $request = Plack::Request->new( $p{env} ); my $response = $request->new_response(200); @@ -27,53 +24,48 @@ sub new { request => $request, response => $response, server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + body => [], + sendfile => undef, }, $class; - $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( plack => $self ); - + $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ); return $self; } -sub session { $_[0]{session} } -sub env { $_[0]{env} } -sub request { $_[0]{request} } -sub response { $_[0]{response} } -sub server { $_[0]{server} } - our $AUTOLOAD; - sub AUTOLOAD { - my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!plack->$what(@_)"; } -sub uri { shift->request->request_uri(@_) } -sub param { shift->request->param(@_) } -sub params { shift->request->params(@_) } -sub headers_in { shift->request->headers(@_) } +# Emulate/delegate/fake Apache2::* subs +sub uri { shift->{request}->request_uri(@_) } +sub param { shift->{request}->param(@_) } +sub params { shift->{request}->params(@_) } +sub headers_in { shift->{request}->headers(@_) } sub headers_out { shift->{headers_out} } -sub protocol { shift->request->protocol(@_) } -sub status { shift->response->status(@_) } +sub protocol { shift->{request}->protocol(@_) } +sub status { shift->{response}->status(@_) } +sub sendfile { $_[0]->{sendfile} = $_[1] } +sub content_type { shift->{response}->content_type(@_) } sub status_line {} +sub DESTROY {} +sub auth_type {} # should we support this? -sub auth_type { - # should we support this? -} +sub server { shift->{server} } +sub request_cookies { shift->{request}->cookies } +sub response_cookies { shift->{response}->cookies(@_) } # TODO: I suppose this should do some sort of IO::Handle thing -my @body; -sub print { shift; push @body, @_ } - -my $sendfile; -sub sendfile { shift; $sendfile = shift; } +sub print { + my $self = shift; + push @{$self->{body}}, @_; +} sub dir_config { - my $self = shift; - my $c = shift; - return $self->env->{"wg.DIR_CONFIG.$c"}; + my ($self, $c) = @_; + return $self->{env}->{"wg.DIR_CONFIG.$c"}; } sub pnotes { @@ -96,7 +88,7 @@ sub push_handlers { my ($x, $sub) = @_; # log it - carp "push_handlers($x)"; + # carp "push_handlers($x)"; # run it # returns something like Apache2::Const::OK, which we just ignore because we're not modperl @@ -107,16 +99,15 @@ sub push_handlers { sub finalize { my $self = shift; - if ($sendfile && open my $fh, '<', $sendfile) { - $self->response->body( $fh ); + my $response = $self->{response}; + if ($self->{sendfile} && open my $fh, '<', $self->{sendfile}) { + $response->body( $fh ); } else { - $self->response->body( $sendfile || \@body); + $response->body( $self->{body} ); } - return $self->response->finalize; + return $response->finalize; } -sub content_type { shift->response->content_type(@_) } - # #sub headers_in { # my $self = shift; @@ -124,6 +115,8 @@ sub content_type { shift->response->content_type(@_) } # return $self->plack->headers(@_); #} +################################################ + package WebGUI::Session::Plack::Server; use strict; @@ -135,24 +128,21 @@ sub new { bless { @_ }, $class; } -sub env { shift->{env} } - our $AUTOLOAD; sub AUTOLOAD { - my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!server->$what(@_)"; - return; } +sub DESTROY {} sub dir_config { - my $self = shift; - my $c = shift; - return $self->env->{"wg.DIR_CONFIG.$c"}; + my ($self, $c) = @_; + return $self->{env}->{"wg.DIR_CONFIG.$c"}; } +################################################ + package WebGUI::Session::Plack::HeadersOut; use strict; @@ -166,476 +156,16 @@ sub new { our $AUTOLOAD; sub AUTOLOAD { - my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!headers_out->$what(@_)"; - return; } -sub set { shift->{plack}->response->headers->header(@_) } +sub DESTROY {} -# -- +# Called by wG as $session->response->headers_out->set('Content-Type' => 'text/html'); +sub set { shift->{response}->headers->header(@_) } -## CGI request are _always_ main, and there is never a previous or a next -## internal request. -#sub main {} -#sub prev {} -#sub next {} -#sub is_main {1} -#sub is_initial_req {1} -# -## What to do with this? -## sub allowed {} -# -#sub method { -# $_[0]->query->request_method; -#} -# -## There mut be a mapping for this. -## sub method_number {} -# -## Can CGI.pm tell us this? -## sub bytes_sent {0} -# -## The request line sent by the client." Poached from Apache::Emulator. -#sub the_request { -# my $self = shift; -# $self->{the_request} ||= join ' ', $self->method, -# ( $self->{query}->query_string -# ? $self->uri . '?' . $self->{query}->query_string -# : $self->uri ), -# $self->{query}->server_protocol; -#} -# -## Is CGI ever a proxy request? -## sub proxy_req {} -# -#sub header_only { $_[0]->method eq 'HEAD' } -# -#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } -# -#sub hostname { $_[0]->{query}->server_name } -# -## CGI says "use this when using virtual hosts". It falls back to -## CGI->server_port. -#sub get_server_port { $_[0]->{query}->virtual_port } -# -## Fake it by just giving the current time. -#sub request_time { time } -# -#sub uri { -# my $self = shift; -# -# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; -#} -# -## Is this available in CGI? -## sub filename {} -# -## "The $r->location method will return the path of the -## section from which the current "Perl*Handler" -## is being called." This is irrelevant, I think. -## sub location {} -# -#sub path_info { $_[0]->{query}->path_info } -# -#sub args { -# my $self = shift; -# if (@_) { -# # Assign args here. -# } -# return $self->{query}->Vars unless wantarray; -# # Do more here to return key => arg values. -#} -# -#sub headers_in { -# my $self = shift; -# -# # Create the headers table if necessary. Decided how to build it based on -# # information here: -# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 -# # -# # Try to get as much info as possible from CGI.pm, which has -# # workarounds for things like the IIS PATH_INFO bug. -# # -# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new -# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. -# 'Content-Length' => $ENV{CONTENT_LENGTH}, -# 'Content-Type' => -# ( $self->{query}->can('content_type') ? -# $self->{query}->content_type : -# $ENV{CONTENT_TYPE} -# ), -# # Convert HTTP environment variables back into their header names. -# map { -# my $k = ucfirst lc; -# $k =~ s/_(.)/-\u$1/g; -# ( $k => $self->{query}->http($_) ) -# } grep { s/^HTTP_// } keys %ENV -# ); -# -# -# # Give 'em the hash list of the hash table. -# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; -#} -# -#sub header_in { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_in; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -# -## The $r->content method will return the entity body -## read from the client, but only if the request content -## type is "application/x-www-form-urlencoded". When -## called in a scalar context, the entire string is -## returned. When called in a list context, a list of -## parsed key => value pairs are returned. *NOTE*: you -## can only ask for this once, as the entire body is read -## from the client. -## Not sure what to do with this one. -## sub content {} -# -## I think this may be irrelevant under CGI. -## sub read {} -# -## Use LWP? -#sub get_remote_host {} -#sub get_remote_logname {} -# -#sub http_header { -# my $self = shift; -# my $h = $self->headers_out; -# my $e = $self->err_headers_out; -# my $method = exists $h->{Location} || exists $e->{Location} ? -# 'redirect' : 'header'; -# return $self->query->$method(tied(%$h)->cgi_headers, -# tied(%$e)->cgi_headers); -#} -# -#sub send_http_header { -# my $self = shift; -# -# return if $self->http_header_sent; -# -# print STDOUT $self->http_header; -# -# $self->{http_header_sent} = 1; -#} -# -#sub http_header_sent { shift->{http_header_sent} } -# -## How do we know this under CGI? -## sub get_basic_auth_pw {} -## sub note_basic_auth_failure {} -# -## I think that this just has to be empty. -#sub handler {} -# -#sub notes { -# my ($self, $key) = (shift, shift); -# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; -# return wantarray ? %{$self->{notes}} : $self->{notes} -# unless defined $key; -# return $self->{notes}{$key} = "$_[0]" if @_; -# return $self->{notes}{$key}; -#} -# -#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 subprocess_env { -# my ($self, $key) = (shift, shift); -# unless (defined $key) { -# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); -# return wantarray ? %{$self->{subprocess_env}} : -# $self->{subprocess_env}; -# -# } -# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); -# return $self->{subprocess_env}{$key} = "$_[0]" if @_; -# return $self->{subprocess_env}{$key}; -#} -# -#sub content_type { -# shift->header_out('Content-Type', @_); -#} -# -#sub content_encoding { -# shift->header_out('Content-Encoding', @_); -#} -# -#sub content_languages { -# my ($self, $langs) = @_; -# return unless $langs; -# my $h = shift->headers_out; -# for my $l (@$langs) { -# $h->add('Content-Language', $l); -# } -#} -# -#sub status { -# shift->header_out('Status', @_); -#} -# -#sub status_line { -# # What to do here? Should it be managed differently than status? -# my $self = shift; -# if (@_) { -# my $status = shift =~ /^(\d+)/; -# return $self->header_out('Status', $status); -# } -# return $self->header_out('Status'); -#} -# -#sub headers_out { -# my $self = shift; -# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; -#} -# -#sub header_out { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_out; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -#sub err_headers_out { -# my $self = shift; -# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; -#} -# -#sub err_header_out { -# my ($self, $err_header) = (shift, shift); -# my $h = $self->err_headers_out; -# return @_ ? $h->set($err_header, shift) : $h->get($err_header); -#} -# -#sub no_cache { -# my $self = shift; -# $self->header_out(Pragma => 'no-cache'); -# $self->header_out('Cache-Control' => 'no-cache'); -#} -# -#sub print { -# shift; -# print @_; -#} -# -#sub send_fd { -# my ($self, $fd) = @_; -# local $_; -# -# print STDOUT while defined ($_ = <$fd>); -#} -# -## Should this perhaps throw an exception? -## sub internal_redirect {} -## sub internal_redirect_handler {} -# -## Do something with ErrorDocument? -## sub custom_response {} -# -## I think we've made this essentially the same thing. -#BEGIN { -# local $^W; -# *send_cgi_header = \&send_http_header; -#} -# -## Does CGI support logging? -## sub log_reason {} -## sub log_error {} -#sub warn { -# shift; -# print STDERR @_, "\n"; -#} -# -#sub params { -# my $self = shift; -# return _cgi_request_args($self->query, $self->query->request_method); -#} -# -#sub _cgi_request_args{ -# my ($q, $method) = @_; -# -# my %args; -# -# # Checking that there really is no query string when the method is -# # not POST is important because otherwise ->url_param returns a -# # parameter named 'keywords' with a value of () (empty array). -# # This is apparently a feature related to queries or -# # something (see the CGI.pm) docs. It makes my head hurt. - dave -# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); -# -# foreach my $key ( map { $q->$_() } @methods ) { -# next if exists $args{$key}; -# my @values = map { $q->$_($key) } @methods; -# $args{$key} = @values == 1 ? $values[0] : \@values; -# } -# -# return wantarray ? %args : \%args; -#} -# -# -############################################################ -#package WebGUI::Session::Request::FakeTable; -## Analogous to Apache::Table. -#use strict; -#use warnings; -# -#sub new { -# my $class = shift; -# my $self = {}; -# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; -# %$self = @_ if @_; -# return bless $self, ref $class || $class; -#} -# -#sub set { -# my ($self, $header, $value) = @_; -# defined $value ? $self->{$header} = $value : delete $self->{$header}; -#} -# -#sub unset { -# my $self = shift; -# delete $self->{shift()}; -#} -# -#sub add { -# tied(%{shift()})->add(@_); -#} -# -#sub clear { -# %{shift()} = (); -#} -# -#sub get { -# tied(%{shift()})->get(@_); -#} -# -#sub merge { -# my ($self, $key, $value) = @_; -# if (defined $self->{$key}) { -# $self->{$key} .= ',' . $value; -# } else { -# $self->{$key} = "$value"; -# } -#} -# -#sub do { -# my ($self, $code) = @_; -# while (my ($k, $val) = each %$self) { -# for my $v (ref $val ? @$val : $val) { -# return unless $code->($k => $v); -# } -# } -#} -# -############################################################ -#package WebGUI::Session::Request::FakeTableHash; -## Used by WebGUI::Session::Request::FakeTable. -#use strict; -#use warnings; -# -#sub TIEHASH { -# my $class = shift; -# return bless {}, ref $class || $class; -#} -# -#sub _canonical_key { -# my $key = lc shift; -# # CGI really wants a - before each header -# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; -#} -# -#sub STORE { -# my ($self, $key, $value) = @_; -# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; -#} -# -#sub add { -# my ($self, $key) = (shift, shift); -# return unless defined $_[0]; -# my $value = ref $_[0] ? "$_[0]" : $_[0]; -# my $ckey = _canonical_key $key; -# if (exists $self->{$ckey}) { -# if (ref $self->{$ckey}[1]) { -# push @{$self->{$ckey}[1]}, $value; -# } else { -# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; -# } -# } else { -# $self->{$ckey} = [ $key => $value ]; -# } -#} -# -#sub DELETE { -# my ($self, $key) = @_; -# my $ret = delete $self->{_canonical_key $key}; -# return $ret->[1]; -#} -# -#sub FETCH { -# my ($self, $key) = @_; -# # Grab the values first so that we don't autovivicate the key. -# my $val = $self->{_canonical_key $key} or return; -# if (my $ref = ref $val->[1]) { -# return unless $val->[1][0]; -# # Return the first value only. -# return $val->[1][0]; -# } -# return $val->[1]; -#} -# -#sub get { -# my ($self, $key) = @_; -# my $ckey = _canonical_key $key; -# return unless exists $self->{$ckey}; -# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; -# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; -#} -# -#sub CLEAR { -# %{shift()} = (); -#} -# -#sub EXISTS { -# my ($self, $key)= @_; -# return exists $self->{_canonical_key $key}; -#} -# -#sub FIRSTKEY { -# my $self = shift; -# # Reset perl's iterator. -# keys %$self; -# # Get the first key via perl's iterator. -# my $first_key = each %$self; -# return undef unless defined $first_key; -# return $self->{$first_key}[0]; -#} -# -#sub NEXTKEY { -# my ($self, $nextkey) = @_; -# # Get the next key via perl's iterator. -# my $next_key = each %$self; -# return undef unless defined $next_key; -# return $self->{$next_key}[0]; -#} -# -#sub cgi_headers { -# my $self = shift; -# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; -#} -# -#sub _map_header_key_to_cgi_key { -# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; -#} +################################################ 1; From b4698f7725430a1324cf545fb0ed7adc7f9f839c Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 19:28:19 +1100 Subject: [PATCH 09/92] fixed cookie handling --- etc/dev.localhost.localdomain.psgi | 7 +- lib/WebGUI/Session/Http.pm | 20 ++-- lib/WebGUI/Session/Plack.pm | 146 +++++++++++++++++------------ 3 files changed, 99 insertions(+), 74 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index df9d00c61..31a4e55c9 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -32,12 +32,11 @@ builder { path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; - add 'Plack::Middleware::XFramework', - framework => 'WebGUI'; + add 'Plack::Middleware::XFramework', framework => 'WebGUI'; # Already enabled by plackup script - # add 'Plack::Middleware::AccessLog', + # add 'Plack::Middleware::AccessLog', # format => "combined"; $app; -} \ No newline at end of file +} diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 473d55835..0861d2d9f 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -93,7 +93,7 @@ sub getCookies { my $self = shift; if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->request_cookies; + return $self->session->request->get_request_cookies; } # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) @@ -389,15 +389,17 @@ sub setCookie { $ttl = (defined $ttl ? $ttl : '+10y'); if ($self->session->request) { - if ($self->session->request->isa('WebGUI::Session::Plack')) { - $self->session->request->response_cookies->{$name} = { - value => $value, - path => '/', - expires => $ttl ne 'session' ? $ttl : undef, - domain => $domain, - }; + if ( $self->session->request->isa('WebGUI::Session::Plack') ) { + $self->session->request->set_response_cookie( + $name => { + value => $value, + path => '/', + expires => $ttl ne 'session' ? $ttl : undef, + domain => $domain, + } + ); return; - } + } require Apache2::Cookie; my $cookie = Apache2::Cookie->new($self->session->request, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 2a123207e..d0709c176 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -11,73 +11,78 @@ This class is used instead of WebGUI::Session::Request when wg is started via pl =cut sub new { - my ($class, %p) = @_; + 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 $request = Plack::Request->new( $p{env} ); my $response = $request->new_response(200); - - my $self = bless { + + bless { %p, - pnotes => {}, - request => $request, - response => $response, - server => WebGUI::Session::Plack::Server->new( env => $p{env} ), - body => [], - sendfile => undef, + pnotes => {}, + request => $request, + response => $response, + server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + headers_out => WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ), + body => [], + sendfile => undef, }, $class; - - $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ); - return $self; } our $AUTOLOAD; + sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!plack->$what(@_)"; + carp "!!plack->$what(@_)" unless $what eq 'DESTROY'; } # Emulate/delegate/fake Apache2::* subs -sub uri { shift->{request}->request_uri(@_) } -sub param { shift->{request}->param(@_) } -sub params { shift->{request}->params(@_) } -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 uri { shift->{request}->request_uri(@_) } +sub param { shift->{request}->param(@_) } +sub params { shift->{request}->params(@_) } +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 content_type { shift->{response}->content_type(@_) } -sub status_line {} -sub DESTROY {} -sub auth_type {} # should we support this? +sub server { shift->{server} } +sub status_line { } +sub auth_type { } # should we support this? -sub server { shift->{server} } -sub request_cookies { shift->{request}->cookies } -sub response_cookies { shift->{response}->cookies(@_) } +# These two cookie subs are called from our wG Plack-specific code +sub get_request_cookies { shift->{request}->cookies } # returns hashref of all request cookies + +sub set_response_cookie { + my ( $self, $name, $val ) = @_; + + #warn "setting cookies $name => " . Data::Dumper::Dumper($val); + $self->{response}->cookies->{$name} = $val; +} # TODO: I suppose this should do some sort of IO::Handle thing -sub print { - my $self = shift; - push @{$self->{body}}, @_; +sub print { + my $self = shift; + push @{ $self->{body} }, @_; } sub dir_config { - my ($self, $c) = @_; + my ( $self, $c ) = @_; return $self->{env}->{"wg.DIR_CONFIG.$c"}; } sub pnotes { - my ($self, $key) = (shift, shift); - return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key; + 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) { + my ( $self, $user ) = @_; + if ( defined $user ) { $self->{user} = $user; } $self->{user}; @@ -85,35 +90,39 @@ sub user { sub push_handlers { my $self = shift; - my ($x, $sub) = @_; - + my ( $x, $sub ) = @_; + # log it # carp "push_handlers($x)"; - - # run it + + # 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 $self = shift; my $response = $self->{response}; - if ($self->{sendfile} && open my $fh, '<', $self->{sendfile}) { - $response->body( $fh ); - } else { + if ( $self->{sendfile} && open my $fh, '<', $self->{sendfile} ) { + $response->body($fh); + } + else { $response->body( $self->{body} ); } return $response->finalize; } -# -#sub headers_in { -# my $self = shift; -# return unless $self->plack; -# return $self->plack->headers(@_); -#} +sub no_cache { + my ( $self, $doit ) = @_; + if ($doit) { + $self->{response}->headers->push_header( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' ); + } + else { + $self->{response}->headers->remove_header( 'Pragma', 'Cache-control' ); + } +} ################################################ @@ -125,19 +134,19 @@ use Carp; sub new { my $class = shift; - bless { @_ }, $class; + bless {@_}, $class; } our $AUTOLOAD; + sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!server->$what(@_)"; + carp "!!server->$what(@_)" unless $what eq 'DESTROY'; } -sub DESTROY {} sub dir_config { - my ($self, $c) = @_; + my ( $self, $c ) = @_; return $self->{env}->{"wg.DIR_CONFIG.$c"}; } @@ -145,26 +154,41 @@ sub dir_config { package WebGUI::Session::Plack::HeadersOut; +=head1 DESCRIPTION + +This class is required so that wG can call: + + $session->response->headers_out->set('a' => 'b'); + +But for code under out control we just use: + + $response->headers->push_header('a' => 'b'); + $repsonse->headers->remove_header('a'); + +=cut + use strict; use warnings; use Carp; sub new { my $class = shift; - bless { @_ }, $class; + bless {@_}, $class; } our $AUTOLOAD; + sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!headers_out->$what(@_)"; + carp "!!headers_out->$what(@_)" unless $what eq 'DESTROY'; } -sub DESTROY {} - -# Called by wG as $session->response->headers_out->set('Content-Type' => 'text/html'); -sub set { shift->{response}->headers->header(@_) } +# This is the sub that wG calls +sub set { + my $self = shift; + $self->{response}->headers->push_header(@_); +} ################################################ From 79c3c232154038226f6ad57b736984a4d91076de Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 20:34:41 +1100 Subject: [PATCH 10/92] Headers via Plack::Util::headers Uploads work now too --- lib/WebGUI/Session/Plack.pm | 70 ++++++++++++------------------------- 1 file changed, 22 insertions(+), 48 deletions(-) diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index d0709c176..a12dd30db 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -20,11 +20,11 @@ sub new { bless { %p, - pnotes => {}, - request => $request, - response => $response, - server => WebGUI::Session::Plack::Server->new( env => $p{env} ), - headers_out => WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ), + 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; @@ -49,16 +49,25 @@ sub status { shift->{response}->status(@_) } sub sendfile { $_[0]->{sendfile} = $_[1] } sub content_type { shift->{response}->content_type(@_) } sub server { shift->{server} } +sub method { shift->{request}->method } +sub upload { shift->{request}->upload(@_) } sub status_line { } sub auth_type { } # should we support this? # These two cookie subs are called from our wG Plack-specific code -sub get_request_cookies { shift->{request}->cookies } # returns hashref of all request cookies +sub get_request_cookies { + + # Get the hash of { name => CGI::Simple::Cookie } + my $cookies = shift->{request}->cookies; + + # Convert into { name => value } as expected by wG + my %c = map { $_->name => $_->value } values %{$cookies}; + + return \%c; +} sub set_response_cookie { my ( $self, $name, $val ) = @_; - - #warn "setting cookies $name => " . Data::Dumper::Dumper($val); $self->{response}->cookies->{$name} = $val; } @@ -111,16 +120,17 @@ sub finalize { else { $response->body( $self->{body} ); } + $response->headers( $self->{headers_out}->headers ); return $response->finalize; } sub no_cache { my ( $self, $doit ) = @_; if ($doit) { - $self->{response}->headers->push_header( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' ); + $self->{headers_out}->set( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' ); } else { - $self->{response}->headers->remove_header( 'Pragma', 'Cache-control' ); + $self->{headers_out}->remove( 'Pragma', 'Cache-control' ); } } @@ -152,44 +162,8 @@ sub dir_config { ################################################ -package WebGUI::Session::Plack::HeadersOut; +package Plack::Request::Upload; -=head1 DESCRIPTION - -This class is required so that wG can call: - - $session->response->headers_out->set('a' => 'b'); - -But for code under out control we just use: - - $response->headers->push_header('a' => 'b'); - $repsonse->headers->remove_header('a'); - -=cut - -use strict; -use warnings; -use Carp; - -sub new { - my $class = shift; - bless {@_}, $class; -} - -our $AUTOLOAD; - -sub AUTOLOAD { - my $what = $AUTOLOAD; - $what =~ s/.*:://; - carp "!!headers_out->$what(@_)" unless $what eq 'DESTROY'; -} - -# This is the sub that wG calls -sub set { - my $self = shift; - $self->{response}->headers->push_header(@_); -} - -################################################ +sub link { shift->link_to(@_) } 1; From e9893b25f419705aaedf43dc4795bcb26b73b069 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 22:46:06 +1100 Subject: [PATCH 11/92] Added WGAccess Middleware --- etc/dev.localhost.localdomain.psgi | 46 +++++++------ lib/Plack/Middleware/WGAccess.pm | 104 +++++++++++++++++++++++++++++ 2 files changed, 130 insertions(+), 20 deletions(-) create mode 100644 lib/Plack/Middleware/WGAccess.pm diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 31a4e55c9..6ed510b33 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,42 +1,48 @@ BEGIN { - - # This is just a temporary hack - our $WEBGUI_ROOT = '/data/WebGUI'; - our $WEBGUI_DOMAINS = '/data/domains'; - our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; + # Define your site settings here + # These are the config values that normally appear in your wre's + # site.modperl.conf and site.modproxy.conf + our $WEBGUI_ROOT = '/data/WebGUI'; + our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; + our $DOCUMENT_ROOT = '/data/domains/dev.localhost.localdomain/public'; } use local::lib $WEBGUI_ROOT; use WebGUI; -use Plack::Middleware; use Plack::Builder; -my $app = sub { +my %SETTINGS = ( + 'wg.WEBGUI_ROOT' => $WEBGUI_ROOT, + 'wg.WEBGUI_CONFIG' => "$WEBGUI_CONFIG.conf", + 'wg.DOCUMENT_ROOT' => $DOCUMENT_ROOT, + 'wg.DIR_CONFIG.WebguiRoot' => $WEBGUI_ROOT, + 'wg.DIR_CONFIG.WebguiConfig' => "$WEBGUI_CONFIG.conf", +); + +my $wg = sub { my $env = shift; - $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; - $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; - $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; - $env->{'wg.DIR_CONFIG.WebguiConfig'} = $env->{'wg.WEBGUI_CONFIG'}; + @{$env}{ keys %SETTINGS } = values %SETTINGS; WebGUI::handle_psgi($env); }; -# Apply some Middleware builder { - # /extras + # /extras - deliver via Plack::Middleware::Static add 'Plack::Middleware::Static', path => qr{^/extras/}, - root => "$WEBGUI_ROOT/www/"; + root => "$SETTINGS{'wg.WEBGUI_ROOT'}/www/"; - # /uploads (ignore .wgaccess for now..) - add 'Plack::Middleware::Static', - path => qr{^/uploads/}, - root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; + # /uploads - deliver via Plack::Middleware::WGAccess + # This takes the place of WebGUI::URL::Uploads in handling .wgaccess and + # delivery of static files in /uploads + add 'Plack::Middleware::WGAccess', + path => qr{^/uploads/}, + settings => {%SETTINGS}; add 'Plack::Middleware::XFramework', framework => 'WebGUI'; - # Already enabled by plackup script + # AccessLog already enabled by default if you are using the plackup script # add 'Plack::Middleware::AccessLog', # format => "combined"; - $app; + $wg; } diff --git a/lib/Plack/Middleware/WGAccess.pm b/lib/Plack/Middleware/WGAccess.pm new file mode 100644 index 000000000..ce7b71228 --- /dev/null +++ b/lib/Plack/Middleware/WGAccess.pm @@ -0,0 +1,104 @@ +package Plack::Middleware::WGAccess; +use strict; +use warnings; +use base qw/Plack::Middleware::Static/; +use Path::Class 'dir'; +__PACKAGE__->mk_accessors('settings'); + +=head1 NAME + +Plack::Middleware::WGAccess + +=head1 DESCRIPTION + +Plack Middleware that delivers static files with .wgaccess awareness + +=cut + +sub _handle_static { + my($self, $env) = @_; + + # Populate $env with $self->settings so that we get consistent wg API behaviour + my %settings = %{$self->settings}; + @{$env}{keys %settings} = values %settings; + + # Populate $self->root from $SETTINGS so that it doesn't need to be specified in psgi file + $self->root($settings{'wg.DOCUMENT_ROOT'}); + + ####################################### + # Copied from Plack::Middleware::Static::_handle_static + + my $path_match = $self->path or return; + + if ($env->{PATH_INFO} =~ m!\.\.[/\\]!) { + return $self->return_403; + } + + my $path = do { + my $matched; + local $_ = $env->{PATH_INFO}; + if (ref $path_match eq 'CODE') { + $matched = $path_match->($_); + } else { + $matched = $_ =~ $path_match; + } + return unless $matched; + $_; + } or return; + + my $docroot = dir($self->root || "."); + my $file = $docroot->file(File::Spec::Unix->splitpath($path)); + my $realpath = Cwd::realpath($file->absolute->stringify); + + # Is the requested path within the root? + if ($realpath && !$docroot->subsumes($realpath)) { + return $self->return_403; + } + + # Does the file actually exist? + if (!$realpath || !-f $file) { + return $self->return_404; + } + + # If the requested file present but lacking the permission to read it? + if (!-r $file) { + return $self->return_403; + } + + ############################### + # Copied from WebGUI::URL::Uploads + my $wgaccess = File::Spec::Unix->catfile($file->dir, '.wgaccess'); + if (-e $wgaccess) { + my $fileContents; + open(my $FILE, "<", $wgaccess); + while (my $line = <$FILE>) { + $fileContents .= $line; + } + close($FILE); + my @privs = split("\n", $fileContents); + unless ($privs[1] eq "7" || $privs[1] eq "1") { + + # Construct request,server,config in the usual way + require WebGUI::Session::Plack; + my $request = WebGUI::Session::Plack->new( env => $env ); + my $server = $request->server; + + my $session = $request->pnotes('wgSession'); + unless (defined $session) { + $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $request->dir_config('WebguiConfig'), $request, $server); + } + my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); + $session->close(); + if ($hasPrivs) { + return $self->SUPER::_handle_static($env); # serve statically + } + else { + return $self->return_403; + } + } + } else { + return $self->SUPER::_handle_static($env); # serve statically + } +} + +1; \ No newline at end of file From 784e0bd73c2a2d91626175f0ce7100d5d5ac959b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 11 Oct 2009 01:07:08 +1100 Subject: [PATCH 12/92] Added Apache CGI/FCGI/mod_perl examples --- apache.conf | 21 +++++++++++++++++++++ etc/dev.localhost.localdomain.cgi | 5 +++++ etc/dev.localhost.localdomain.fcgi | 5 +++++ etc/dev.localhost.localdomain.psgi | 3 ++- lib/WebGUI/Session/Plack.pm | 7 ++++++- 5 files changed, 39 insertions(+), 2 deletions(-) create mode 100644 apache.conf create mode 100755 etc/dev.localhost.localdomain.cgi create mode 100755 etc/dev.localhost.localdomain.fcgi diff --git a/apache.conf b/apache.conf new file mode 100644 index 000000000..7be1edbfe --- /dev/null +++ b/apache.conf @@ -0,0 +1,21 @@ + + 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/ + + diff --git a/etc/dev.localhost.localdomain.cgi b/etc/dev.localhost.localdomain.cgi new file mode 100755 index 000000000..71eee8fab --- /dev/null +++ b/etc/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/etc/dev.localhost.localdomain.fcgi b/etc/dev.localhost.localdomain.fcgi new file mode 100755 index 000000000..431274292 --- /dev/null +++ b/etc/dev.localhost.localdomain.fcgi @@ -0,0 +1,5 @@ +#!/usr/bin/perl +use Plack::Server::FCGI; + +my $app = Plack::Util::load_psgi("/data/WebGUI/etc/dev.localhost.localdomain.psgi"); +Plack::Server::FCGI->new->run($app); diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 6ed510b33..b40d87272 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -6,7 +6,8 @@ BEGIN { our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; our $DOCUMENT_ROOT = '/data/domains/dev.localhost.localdomain/public'; } -use local::lib $WEBGUI_ROOT; +use lib "$WEBGUI_ROOT/lib"; +#use local::lib $WEBGUI_ROOT; use WebGUI; use Plack::Builder; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index a12dd30db..bf4672193 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -47,12 +47,17 @@ sub headers_out { shift->{headers_out} } sub protocol { shift->{request}->protocol(@_) } sub status { shift->{response}->status(@_) } sub sendfile { $_[0]->{sendfile} = $_[1] } -sub content_type { shift->{response}->content_type(@_) } sub server { shift->{server} } sub method { shift->{request}->method } sub upload { shift->{request}->upload(@_) } 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 ); +} # These two cookie subs are called from our wG Plack-specific code sub get_request_cookies { From b9bff5a2f6edb463f811dd9b137e535332c77121 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 11 Oct 2009 19:03:31 +1100 Subject: [PATCH 13/92] Added perlbal and Plack::Middleware::WebGUI to simplify psgi file --- apache.conf | 6 ++++ etc/dev.localhost.localdomain.perlbal | 7 ++++ etc/dev.localhost.localdomain.psgi | 52 ++++++++------------------- lib/Plack/Middleware/WGAccess.pm | 8 ----- lib/Plack/Middleware/WebGUI.pm | 30 ++++++++++++++++ lib/WebGUI/Session/Plack.pm | 44 ++++++++++++----------- 6 files changed, 80 insertions(+), 67 deletions(-) create mode 100644 etc/dev.localhost.localdomain.perlbal create mode 100644 lib/Plack/Middleware/WebGUI.pm diff --git a/apache.conf b/apache.conf index 7be1edbfe..71ea48165 100644 --- a/apache.conf +++ b/apache.conf @@ -18,4 +18,10 @@ 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/etc/dev.localhost.localdomain.perlbal b/etc/dev.localhost.localdomain.perlbal new file mode 100644 index 000000000..98b85382e --- /dev/null +++ b/etc/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/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index b40d87272..ae98f20df 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,49 +1,25 @@ -BEGIN { - # Define your site settings here - # These are the config values that normally appear in your wre's - # site.modperl.conf and site.modproxy.conf - our $WEBGUI_ROOT = '/data/WebGUI'; - our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; - our $DOCUMENT_ROOT = '/data/domains/dev.localhost.localdomain/public'; -} -use lib "$WEBGUI_ROOT/lib"; -#use local::lib $WEBGUI_ROOT; -use WebGUI; use Plack::Builder; - -my %SETTINGS = ( - 'wg.WEBGUI_ROOT' => $WEBGUI_ROOT, - 'wg.WEBGUI_CONFIG' => "$WEBGUI_CONFIG.conf", - 'wg.DOCUMENT_ROOT' => $DOCUMENT_ROOT, - 'wg.DIR_CONFIG.WebguiRoot' => $WEBGUI_ROOT, - 'wg.DIR_CONFIG.WebguiConfig' => "$WEBGUI_CONFIG.conf", -); - -my $wg = sub { - my $env = shift; - @{$env}{ keys %SETTINGS } = values %SETTINGS; - WebGUI::handle_psgi($env); -}; +use lib '/data/WebGUI/lib'; +use WebGUI; builder { + + # Populate $env from site.conf + add 'Plack::Middleware::WebGUI', + root => '/data/WebGUI', + config => 'dev.localhost.localdomain.conf'; - # /extras - deliver via Plack::Middleware::Static + # Handle /extras via Plack::Middleware::Static + # (or Plack::Middleware::WebGUI could do this for us by looking up extrasPath and extrasURL in site.conf) add 'Plack::Middleware::Static', path => qr{^/extras/}, - root => "$SETTINGS{'wg.WEBGUI_ROOT'}/www/"; + root => '/data/WebGUI/www'; - # /uploads - deliver via Plack::Middleware::WGAccess - # This takes the place of WebGUI::URL::Uploads in handling .wgaccess and - # delivery of static files in /uploads + # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) + # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) add 'Plack::Middleware::WGAccess', path => qr{^/uploads/}, - settings => {%SETTINGS}; + root => '/data/domains/dev.localhost.localdomain/public'; - add 'Plack::Middleware::XFramework', framework => 'WebGUI'; - - # AccessLog already enabled by default if you are using the plackup script - # add 'Plack::Middleware::AccessLog', - # format => "combined"; - - $wg; + sub { WebGUI::handle_psgi(shift) }; } diff --git a/lib/Plack/Middleware/WGAccess.pm b/lib/Plack/Middleware/WGAccess.pm index ce7b71228..8c289cfba 100644 --- a/lib/Plack/Middleware/WGAccess.pm +++ b/lib/Plack/Middleware/WGAccess.pm @@ -3,7 +3,6 @@ use strict; use warnings; use base qw/Plack::Middleware::Static/; use Path::Class 'dir'; -__PACKAGE__->mk_accessors('settings'); =head1 NAME @@ -17,13 +16,6 @@ Plack Middleware that delivers static files with .wgaccess awareness sub _handle_static { my($self, $env) = @_; - - # Populate $env with $self->settings so that we get consistent wg API behaviour - my %settings = %{$self->settings}; - @{$env}{keys %settings} = values %settings; - - # Populate $self->root from $SETTINGS so that it doesn't need to be specified in psgi file - $self->root($settings{'wg.DOCUMENT_ROOT'}); ####################################### # Copied from Plack::Middleware::Static::_handle_static diff --git a/lib/Plack/Middleware/WebGUI.pm b/lib/Plack/Middleware/WebGUI.pm new file mode 100644 index 000000000..defa4eda5 --- /dev/null +++ b/lib/Plack/Middleware/WebGUI.pm @@ -0,0 +1,30 @@ +package Plack::Middleware::WebGUI; +use strict; +use warnings; +use base qw/Plack::Middleware/; + +__PACKAGE__->mk_accessors('root', 'config'); + +=head1 NAME + +Plack::Middleware::WebGUI + +=head1 DESCRIPTION + +Plack Middleware that populates $env + +In the future we might want to read the site.conf here and then cache it + +=cut + +sub call { + my $self = shift; + my $env = shift; + + $env->{'wg.WEBGUI_ROOT'} = $self->root; + $env->{'wg.WEBGUI_CONFIG'} = $self->config; + + $self->app->($env); +} + +1; \ No newline at end of file diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index bf4672193..3446718cf 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -39,23 +39,24 @@ sub AUTOLOAD { } # Emulate/delegate/fake Apache2::* subs -sub uri { shift->{request}->request_uri(@_) } -sub param { shift->{request}->param(@_) } -sub params { shift->{request}->params(@_) } -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 status_line { } -sub auth_type { } # should we support this? -sub handler { 'perl-script' } # or not..? +sub uri { shift->{request}->request_uri(@_) } +sub param { shift->{request}->param(@_) } +sub params { shift->{request}->params(@_) } +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) = @_; +sub content_type { + my ( $self, $ct ) = @_; $self->{headers_out}->set( 'Content-Type' => $ct ); } @@ -82,11 +83,6 @@ sub print { push @{ $self->{body} }, @_; } -sub dir_config { - my ( $self, $c ) = @_; - return $self->{env}->{"wg.DIR_CONFIG.$c"}; -} - sub pnotes { my ( $self, $key ) = ( shift, shift ); return wantarray ? %{ $self->{pnotes} } : $self->{pnotes} unless defined $key; @@ -162,6 +158,12 @@ sub AUTOLOAD { sub dir_config { my ( $self, $c ) = @_; + + # Translate the legacy WebguiRoot and WebguiConfig PerlSetVar's into known values + return $self->{env}->{'wg.WEBGUI_ROOT'} if $c eq 'WebguiRoot'; + return $self->{env}->{'wg.WEBGUI_CONFIG'} 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"}; } From cde333e9316921a6b74551c1a9a5be4a31b29ad9 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Thu, 15 Oct 2009 09:48:40 +1100 Subject: [PATCH 14/92] experimental caching --- etc/dev.localhost.localdomain.psgi | 14 +++++++------- lib/Plack/Middleware/WebGUI.pm | 2 -- lib/WebGUI.pm | 22 +++++++++++++++++++--- lib/WebGUI/Session.pm | 2 +- lib/WebGUI/Session/Plack.pm | 4 ++-- 5 files changed, 29 insertions(+), 15 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index ae98f20df..b0f6b63b9 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,23 +1,23 @@ use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; +WebGUI->init( root => '/data/WebGUI', config => 'dev.localhost.localdomain.conf' ); builder { - - # Populate $env from site.conf - add 'Plack::Middleware::WebGUI', - root => '/data/WebGUI', - config => 'dev.localhost.localdomain.conf'; # Handle /extras via Plack::Middleware::Static # (or Plack::Middleware::WebGUI could do this for us by looking up extrasPath and extrasURL in site.conf) - add 'Plack::Middleware::Static', + enable 'Plack::Middleware::Static', path => qr{^/extras/}, root => '/data/WebGUI/www'; # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) - add 'Plack::Middleware::WGAccess', + #enable 'Plack::Middleware::WGAccess', + # path => qr{^/uploads/}, + # root => '/data/domains/dev.localhost.localdomain/public'; + + enable 'Plack::Middleware::Static', path => qr{^/uploads/}, root => '/data/domains/dev.localhost.localdomain/public'; diff --git a/lib/Plack/Middleware/WebGUI.pm b/lib/Plack/Middleware/WebGUI.pm index defa4eda5..748f531f0 100644 --- a/lib/Plack/Middleware/WebGUI.pm +++ b/lib/Plack/Middleware/WebGUI.pm @@ -13,8 +13,6 @@ Plack::Middleware::WebGUI Plack Middleware that populates $env -In the future we might want to read the site.conf here and then cache it - =cut sub call { diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index f60f377de..5ebaed2cc 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -162,15 +162,17 @@ The Apache2::RequestRec object passed in by Apache's mod_perl. sub handler { my $request = shift; # either apache request object or PSGI env hash - my $server; + my ($server, $config); if ($request->isa('WebGUI::Session::Plack')) { $server = $request->server; + $config = WebGUI->config; } else { $request = Apache2::Request->new($request); $server = Apache2::ServerUtil->server; #instantiate the server api + my $configFile = shift || $request->dir_config('WebguiConfig'); #either we got a config file, or we'll build it from the request object's settings + $config = WebGUI::Config->new($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object } - 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 $config = WebGUI::Config->new($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object + my $error = ""; my $matchUri = $request->uri; my $gateway = $config->get("gateway"); @@ -231,5 +233,19 @@ sub handle_psgi { return $plack->finalize; } +# Experimental speed boost +my ($root, $config_file, $config); +sub init { + my $class = shift; + my %opts = @_; + $root = $opts{root}; + $config_file = $opts{config}; + $config = WebGUI::Config->new($root, $config_file); + warn 'INIT'; +} +sub config { $config } +sub root { $root } +sub config_file { $config_file } + 1; diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 1cc1d497b..942f3057e 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -460,7 +460,7 @@ sub open { my $configFile = shift; my $request = shift; my $server = shift; - my $config = WebGUI::Config->new($webguiRoot,$configFile); + my $config = WebGUI->config || WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 3446718cf..1b552ffa1 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -160,8 +160,8 @@ sub dir_config { my ( $self, $c ) = @_; # Translate the legacy WebguiRoot and WebguiConfig PerlSetVar's into known values - return $self->{env}->{'wg.WEBGUI_ROOT'} if $c eq 'WebguiRoot'; - return $self->{env}->{'wg.WEBGUI_CONFIG'} if $c eq 'WebguiConfig'; + 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"}; From 97432e24075377dd8e8d07c49ba4ecb8d0f4f760 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 5 Mar 2010 20:11:06 -0500 Subject: [PATCH 15/92] Updated to reflect changes in Plack::Request API --- lib/WebGUI.pm | 2 +- lib/WebGUI/Session/Http.pm | 22 ++++++++++------------ lib/WebGUI/Session/Plack.pm | 21 ++------------------- 3 files changed, 13 insertions(+), 32 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 5ebaed2cc..0fb6eff04 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -165,7 +165,7 @@ sub handler { my ($server, $config); if ($request->isa('WebGUI::Session::Plack')) { $server = $request->server; - $config = WebGUI->config; + $config = WebGUI->config; # use our cached version } else { $request = Apache2::Request->new($request); $server = Apache2::ServerUtil->server; #instantiate the server api diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 0861d2d9f..0f2dcbae3 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -93,7 +93,7 @@ sub getCookies { my $self = shift; if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->get_request_cookies; + return $self->session->request->{request}->cookies; } # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) @@ -389,17 +389,15 @@ sub setCookie { $ttl = (defined $ttl ? $ttl : '+10y'); if ($self->session->request) { - if ( $self->session->request->isa('WebGUI::Session::Plack') ) { - $self->session->request->set_response_cookie( - $name => { - value => $value, - path => '/', - expires => $ttl ne 'session' ? $ttl : undef, - domain => $domain, - } - ); - return; - } + if ( $self->session->request->isa('WebGUI::Session::Plack') ) { + $self->session->request->{response}->cookies->{$name} = { + value => $value, + path => '/', + expires => $ttl ne 'session' ? $ttl : undef, + domain => $domain, + }; + } + return; require Apache2::Cookie; my $cookie = Apache2::Cookie->new($self->session->request, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 1b552ffa1..c60f04aa8 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -39,9 +39,9 @@ sub AUTOLOAD { } # Emulate/delegate/fake Apache2::* subs -sub uri { shift->{request}->request_uri(@_) } +sub uri { shift->{request}->path_info } sub param { shift->{request}->param(@_) } -sub params { shift->{request}->params(@_) } +sub params { shift->{request}->prameters->mixed(@_) } sub headers_in { shift->{request}->headers(@_) } sub headers_out { shift->{headers_out} } sub protocol { shift->{request}->protocol(@_) } @@ -60,23 +60,6 @@ sub content_type { $self->{headers_out}->set( 'Content-Type' => $ct ); } -# These two cookie subs are called from our wG Plack-specific code -sub get_request_cookies { - - # Get the hash of { name => CGI::Simple::Cookie } - my $cookies = shift->{request}->cookies; - - # Convert into { name => value } as expected by wG - my %c = map { $_->name => $_->value } values %{$cookies}; - - return \%c; -} - -sub set_response_cookie { - my ( $self, $name, $val ) = @_; - $self->{response}->cookies->{$name} = $val; -} - # TODO: I suppose this should do some sort of IO::Handle thing sub print { my $self = shift; From 7603fce5654f362a484db91529da4c8ca54c76d9 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Thu, 11 Mar 2010 20:24:50 -0500 Subject: [PATCH 16/92] Started ripping out mod_perl --- etc/dev.localhost.localdomain.psgi | 34 +++--- lib/Plack/Middleware/WGAccess.pm | 10 +- lib/WebGUI.pm | 189 ++++++++++++----------------- lib/WebGUI/Session.pm | 34 ++---- lib/WebGUI/Session/Http.pm | 61 +++------- lib/WebGUI/Session/Output.pm | 12 +- lib/WebGUI/URL/Content.pm | 85 ++++++------- lib/WebGUI/URL/Uploads.pm | 2 +- sbin/testEnvironment.pl | 3 +- 9 files changed, 181 insertions(+), 249 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index b0f6b63b9..ff33e309b 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,25 +1,29 @@ use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; -WebGUI->init( root => '/data/WebGUI', config => 'dev.localhost.localdomain.conf' ); + +my $wg = WebGUI->new( + root => '/data/WebGUI', + config => 'dev.localhost.localdomain.conf', +); builder { # Handle /extras via Plack::Middleware::Static # (or Plack::Middleware::WebGUI could do this for us by looking up extrasPath and extrasURL in site.conf) - enable 'Plack::Middleware::Static', - path => qr{^/extras/}, - root => '/data/WebGUI/www'; +# enable 'Plack::Middleware::Static', +# path => '^' . $wg->config->get('extrasURL') . '/', +# root => $wg->config->get('extrasPath'); +# +# # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) +# # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) +# #enable 'Plack::Middleware::WGAccess', +# # path => '^' . $wg->config->get('uploadsURL') . '/', +# # root => $wg->config->get('uploadsPath'); +# +# enable 'Plack::Middleware::Static', +# path => '^' . $wg->config->get('uploadsURL') . '/', +# root => $wg->config->get('uploadsPath'); - # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) - # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) - #enable 'Plack::Middleware::WGAccess', - # path => qr{^/uploads/}, - # root => '/data/domains/dev.localhost.localdomain/public'; - - enable 'Plack::Middleware::Static', - path => qr{^/uploads/}, - root => '/data/domains/dev.localhost.localdomain/public'; - - sub { WebGUI::handle_psgi(shift) }; + sub { $wg->run(@_) }; } diff --git a/lib/Plack/Middleware/WGAccess.pm b/lib/Plack/Middleware/WGAccess.pm index 8c289cfba..4308a0b84 100644 --- a/lib/Plack/Middleware/WGAccess.pm +++ b/lib/Plack/Middleware/WGAccess.pm @@ -69,15 +69,11 @@ sub _handle_static { close($FILE); my @privs = split("\n", $fileContents); unless ($privs[1] eq "7" || $privs[1] eq "1") { + my $request = Plack::Request->new( $env ); - # Construct request,server,config in the usual way - require WebGUI::Session::Plack; - my $request = WebGUI::Session::Plack->new( env => $env ); - my $server = $request->server; - - my $session = $request->pnotes('wgSession'); +# my $session = $request->pnotes('wgSession'); unless (defined $session) { - $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $request->dir_config('WebguiConfig'), $request, $server); +# $session = WebGUI::Session->open($env->{dir_config('WebguiRoot'), $request->dir_config('WebguiConfig'), $request ); } my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); $session->close(); diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 0fb6eff04..7ceb2ba6d 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -20,18 +20,17 @@ 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 WebGUI::Config; use WebGUI::Pluggable; use WebGUI::Session; use WebGUI::User; +use Any::Moose; +use Plack::Request; + +has root => ( is => 'ro', required => 1 ); # WEBGUI_ROOT +has config => ( is => 'ro', required => 1 ); # WEBGUI_CONFIG +has session => ( is => 'rw', isa => 'WebGUI::Session' ); =head1 NAME @@ -39,7 +38,7 @@ Package WebGUI =head1 DESCRIPTION -An Apache mod_perl handler for WebGUI. +PSGI handler for WebGUI. =head1 SYNOPSIS @@ -59,7 +58,7 @@ HTTP Basic auth for WebGUI. =head3 requestObject -The Apache2::RequestRec object passed in by Apache's mod_perl. +The Plack::Request object instantiated from the PSGI env hash =head3 user @@ -75,46 +74,43 @@ A reference to a WebGUI::Config object. One will be created if it isn't specifie =cut - sub authen { - my ($request, $username, $password, $config) = @_; - my $server; - if ($request->isa('WebGUI::Session::Plack')) { - $server = $request->server; - } else { - $request = Apache2::Request->new($request); - $server = Apache2::ServerUtil->server; #instantiate the server api - } - my $status = Apache2::Const::OK; + my ($self, $request, $username, $password, $config) = @_; + + my $response = $request->new_response( 200 ); + +# # 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; # TODO - don't think this is supported by Plack::Request +# $username = $request->user; +# } +# else { +# $response->status( 401 ); # HTTP_UNAUTHORIZED; +# return; +# } +# } - # 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($server->dir_config('WebguiRoot'),$request->dir_config('WebguiConfig')); - my $cookies = APR::Request::Apache2->handle($request)->jar(); + $config ||= WebGUI::Config->new( $self->root, $self->config ); # determine session id - my $sessionId = $cookies->{$config->getCookieName}; - my $session = WebGUI::Session->open($server->dir_config('WebguiRoot'),$config->getFilename, $request, $server, $sessionId); - my $log = $session->log; - $request->pnotes(wgSession => $session); + my $sessionId = $request->cookies->{$config->getCookieName}; + + # Instantiate the session object + my $session = $self->session( WebGUI::Session->open($self->root, $self->config, $request, $sessionId) ); + my $log = $session->log; +# $request->pnotes(wgSession => $session); # TODO - no more pnotes 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; + $response->status( 200 ); # OK; + return; } + # TODO - put this back in once we figure out get_basic_auth_pw +# elsif ($status != 200) { # 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); @@ -124,7 +120,8 @@ sub authen { my $auth = eval { WebGUI::Pluggable::instanciate("WebGUI::Auth::".$authMethod, "new", [ $session, $authMethod ] ) }; if ($@) { # got an error $log->error($@); - return Apache2::Const::SERVER_ERROR; + $response->status( 500 ); # SERVER_ERROR + return; } elsif ($auth->authenticate($username, $password)) { # lets try to authenticate $log->info("BASIC AUTH: authenticated successfully"); @@ -136,116 +133,90 @@ sub authen { } $session->{_var} = WebGUI::Session::Var->new($session, $sessionId); $session->user({user=>$user}); - return Apache2::Const::OK; + $response->status( 200 ); # OK + return; } } } $log->security($username." failed to login using HTTP Basic Authentication"); $request->note_basic_auth_failure; - return Apache2::Const::HTTP_UNAUTHORIZED; + $response->status( 401 ); # HTTP_UNAUTHORIZED; + return; } $log->info("BASIC AUTH: skipping"); - return Apache2::Const::HTTP_UNAUTHORIZED; + $response->status( 401 ); # HTTP_UNAUTHORIZED; + return; } #------------------------------------------------------------------- -=head2 handler ( requestObject ) +=head2 run ( env ) Primary http init/response handler for WebGUI. This method decides whether to hand off the request to contentHandler() or uploadsHandler() -=head3 requestObject +=head3 env -The Apache2::RequestRec object passed in by Apache's mod_perl. +The PSGI environment hash =cut -sub handler { - my $request = shift; # either apache request object or PSGI env hash - my ($server, $config); - if ($request->isa('WebGUI::Session::Plack')) { - $server = $request->server; - $config = WebGUI->config; # use our cached version - } else { - $request = Apache2::Request->new($request); - $server = Apache2::ServerUtil->server; #instantiate the server api - my $configFile = shift || $request->dir_config('WebguiConfig'); #either we got a config file, or we'll build it from the request object's settings - $config = WebGUI::Config->new($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object - } - - my $error = ""; +sub run { + my ($self, $env) = @_; + + my $request = Plack::Request->new( $env ); + my $response = $request->new_response( 200 ); + my $config = WebGUI::Config->new( $self->root, $self->config ); + 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 + my $auth = $request->header('Authorization'); + if ($auth && $auth =~ m/^Basic/) { # machine oriented + # Get username and password and hand over to authen $auth =~ s/Basic //; - authen($request, split(":", MIME::Base64::decode_base64($auth), 2), $config); + $self->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)}); + # TODO - what to do here? Should we check response status after call to authen? +# $request->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($request, undef, undef, $config)}); + $self->authen($request, undef, undef, $config); } - # url handlers + # TODO - rip out urlHandler API - convert all to middleware + # all remaining url handlers (probably just Asset which might get converted to something else) should + # set $repsonse->body (e.g. so they can set it to IO) -- they no longer return $output + my $error = ""; + my $gotMatch = 0; + + # TODO - would now be a time to fix the WEBGUI_FATAL label black magic? 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]) }; + eval { WebGUI::Pluggable::run($handler->{$regex}, "handler", [$request, $self->session]) }; if ($@) { $error = $@; last; } else { + # Record that at least one url handler ran successfully $gotMatch = 1; - if ($output ne Apache2::Const::DECLINED) { - return $output; + + # But only return response if body was set + if (defined $response->body ) { # or maybe get a smarter way for url handlers to flag success - b/c this may break delayed IO + return $response->finalize; } } } } - 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; + if ( !$gotMatch ) { + # can't handle the url due to error or misconfiguration + $response->body( "This server is unable to handle the url '".$request->uri."' that you requested. ".$error ); + } + return $response->finalize; } - - -sub handle_psgi { - my $env = shift; - require WebGUI::Session::Plack; - my $plack = WebGUI::Session::Plack->new( env => $env ); - - # returns something like Apache2::Const::OK, which we ignore - my $ret = handler($plack); - - # let Plack::Response do its thing - return $plack->finalize; -} - -# Experimental speed boost -my ($root, $config_file, $config); -sub init { - my $class = shift; - my %opts = @_; - $root = $opts{root}; - $config_file = $opts{config}; - $config = WebGUI::Config->new($root, $config_file); - warn 'INIT'; -} -sub config { $config } -sub root { $root } -sub config_file { $config_file } - 1; - diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 942f3057e..c10ec4ede 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -71,7 +71,6 @@ B It is important to distinguish the difference between a WebGUI session $session->privilege $session->request $session->scratch - $session->server $session->setting $session->stow $session->style @@ -424,7 +423,7 @@ sub log { #------------------------------------------------------------------- -=head2 open ( webguiRoot, configFile [, requestObject, serverObject, sessionId, noFuss ] ) +=head2 open ( webguiRoot, configFile [, requestObject, sessionId, noFuss ] ) Constructor. Opens a closed ( or new ) WebGUI session. @@ -438,11 +437,7 @@ The filename of the config file that WebGUI should operate from. =head3 requestObject -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 Plack::Request object. If this session is being instanciated from the web, this is required. =head3 sessionId @@ -459,23 +454,10 @@ sub open { my $webguiRoot = shift; my $configFile = shift; my $request = shift; - my $server = shift; - my $config = WebGUI->config || WebGUI::Config->new($webguiRoot,$configFile); - my $self = {_config=>$config, _server=>$server}; + my $config = WebGUI::Config->new($webguiRoot,$configFile); + my $self = {_config=>$config }; bless $self , $class; - - # $self->{_request} = $request if (defined $request); - if ($request) { - if ($request->isa('WebGUI::Session::Plack')) { - # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can - $self->{_request} = $request; - } else { - # Use WebGUI::Session::Request to wrap Apache2::* calls - require WebGUI::Session::Request; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); - } - } - + $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; @@ -559,7 +541,7 @@ sub quick { =head2 request ( ) -Returns the Apache request (aka $r) object, or undef if it doesn't exist. +Returns the Plack::Request object, or undef if it doesn't exist. =cut @@ -588,13 +570,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/Http.pm b/lib/WebGUI/Session/Http.pm index 0f2dcbae3..2a141797a 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -91,20 +91,7 @@ Retrieves the cookies from the HTTP header and returns a hash reference containi sub getCookies { my $self = shift; - if ($self->session->request) { - if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->{request}->cookies; - } - - # 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 {}; - } + return $self->session->request ? $self->session->request->cookies : {}; } @@ -219,7 +206,7 @@ sub ifModifiedSince { my $self = shift; my $epoch = 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); return ($epoch > $modified); @@ -282,32 +269,32 @@ sub sendHeader { $self->setNoHeader(1); my %params; if ($self->isRedirect()) { - $request->headers_out->set(Location => $self->getRedirectLocation); - $request->status($self->getStatus); + $request->new_response->header(Location => $self->getRedirectLocation); + $request->new_response->status($self->getStatus); } else { $request->content_type($self->getMimeType); my $cacheControl = $self->getCacheControl; my $date = ($userId eq "1") ? $datetime->epochToHttp($self->getLastModified) : $datetime->epochToHttp; # under these circumstances, don't allow caching if ($userId ne "1" || $cacheControl eq "none" || $self->session->setting->get("preventProxyCache")) { - $request->headers_out->set("Cache-Control" => "private, max-age=1"); + $request->new_response->header("Cache-Control" => "private, max-age=1"); $request->no_cache(1); } # in all other cases, set cache, but tell it to ask us every time so we don't mess with recently logged in users - else { - $request->headers_out->set('Last-Modified' => $date); - $request->headers_out->set('Cache-Control' => "must-revalidate, max-age=" . $cacheControl); + else { + $request->new_response->header( 'Last-Modified' => $date); + $request->new_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); + $request->new_response->header( 'Expires' => $date ); } } if ($self->getFilename) { - $request->headers_out->set('Content-Disposition' => qq{attachment; filename="}.$self->getFilename().'"'); + $request->new_response->headers( 'Content-Disposition' => qq{attachment; filename="}.$self->getFilename().'"'); } - $request->status($self->getStatus()); - $request->status_line($self->getStatus().' '.$self->getStatusDescription()); + $request->new_response->status($self->getStatus()); +# $request->new_response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable } return undef; } @@ -316,10 +303,10 @@ 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->new_response->header('Cache-Control' => 'private'); $request->no_cache(1); - $request->status($self->getStatus()); - $request->status_line($self->getStatus().' '.$self->getStatusDescription()); + $request->response->status($self->getStatus()); +# $request->response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable return undef; } @@ -389,26 +376,12 @@ sub setCookie { $ttl = (defined $ttl ? $ttl : '+10y'); if ($self->session->request) { - if ( $self->session->request->isa('WebGUI::Session::Plack') ) { - $self->session->request->{response}->cookies->{$name} = { + $self->session->request->new_response->cookies->{$name} = { value => $value, path => '/', expires => $ttl ne 'session' ? $ttl : undef, domain => $domain, - }; - } - return; - - 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); + }; } } diff --git a/lib/WebGUI/Session/Output.pm b/lib/WebGUI/Session/Output.pm index fdff0c997..a0bbcb884 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -95,7 +95,17 @@ sub print { print $handle $content; } elsif ($self->session->request) { - $self->session->request->print($content); + # TODO - take away this hack + if (ref $self->session->request->body eq 'ARRAY') { + push @{$self->session->request->body}, $content; + } else { + if ($self->session->request->logger) { + $self->session->request->logger->({ level => 'warn', message => "dropping content: $content" }); + } else { + warn "dropping content: $content"; + } + } +# $self->session->request->print($content); } else { print $content; diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 14a2d8fd4..3116d1807 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -15,7 +15,6 @@ package WebGUI::URL::Content; =cut use strict; -use Apache2::Const -compile => qw(OK DECLINED); use WebGUI::Affiliate; use WebGUI::Exception; use WebGUI::Pluggable; @@ -42,7 +41,7 @@ These subroutines are available from this package: #------------------------------------------------------------------- -=head2 handler ( request, server, config ) +=head2 handler ( request, session ) The Apache request handler for this package. @@ -61,55 +60,51 @@ 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'); - unless (defined $session) { - $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); + my ($request, $session) = @_; + my $config = $session->config; +# my $session = $request->pnotes('wgSession'); # TODO - no more pnotes +# unless (defined $session) { + # TODO - fix this - server is gone +# $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); +# } + WEBGUI_FATAL: 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); } - WEBGUI_FATAL: 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; } - elsif ( $@ ) { - $session->errorHandler->error( $@ ); + if ($output eq "empty") { + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } + last; } - 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; + 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; - 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; + } + $session->close; } 1; diff --git a/lib/WebGUI/URL/Uploads.pm b/lib/WebGUI/URL/Uploads.pm index 36ca8470a..e96e4ec84 100644 --- a/lib/WebGUI/URL/Uploads.pm +++ b/lib/WebGUI/URL/Uploads.pm @@ -62,7 +62,7 @@ sub handler { unless ($privs[1] eq "7" || $privs[1] eq "1") { my $session = $request->pnotes('wgSession'); unless (defined $session) { - $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); +# $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request); } my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); $session->close(); diff --git a/sbin/testEnvironment.pl b/sbin/testEnvironment.pl index 13af38adb..5d7653f8b 100755 --- a/sbin/testEnvironment.pl +++ b/sbin/testEnvironment.pl @@ -105,7 +105,8 @@ 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("URI::Escape", "3.29" ); checkModule("POSIX" ); checkModule("List::Util" ); From 5f549b13054cbc2f92713e866f6898bff6d0a97c Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 13 Mar 2010 11:31:32 -0500 Subject: [PATCH 17/92] Ready to start thinking about IO bound delayed response --- lib/WebGUI.pm | 34 +++++++++++++++++--------- lib/WebGUI/Session.pm | 19 +++++++++++++-- lib/WebGUI/Session/Http.pm | 46 +++++++++++++++++------------------- lib/WebGUI/Session/Output.pm | 22 +++++++++-------- 4 files changed, 74 insertions(+), 47 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 7ceb2ba6d..75527b733 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -25,11 +25,11 @@ use WebGUI::Config; use WebGUI::Pluggable; use WebGUI::Session; use WebGUI::User; -use Any::Moose; +use Moose; use Plack::Request; -has root => ( is => 'ro', required => 1 ); # WEBGUI_ROOT -has config => ( is => 'ro', required => 1 ); # WEBGUI_CONFIG +has root => ( is => 'ro', required => 1 ); # WEBGUI_ROOT, e.g. /data/WebGUI +has config => ( is => 'ro', required => 1 ); # Site config, e.g. dev.localhost.localdomain.conf has session => ( is => 'rw', isa => 'WebGUI::Session' ); =head1 NAME @@ -77,8 +77,6 @@ A reference to a WebGUI::Config object. One will be created if it isn't specifie sub authen { my ($self, $request, $username, $password, $config) = @_; - my $response = $request->new_response( 200 ); - # # set username and password if it's an auth handler # if ($username eq "") { # if ($request->auth_type eq "Basic") { @@ -103,7 +101,7 @@ sub authen { if (defined $sessionId && $session->user->isRegistered) { # got a session id passed in or from a cookie $log->info("BASIC AUTH: using cookie"); - $response->status( 200 ); # OK; + $session->response->status( 200 ); # OK return; } # TODO - put this back in once we figure out get_basic_auth_pw @@ -120,7 +118,7 @@ sub authen { my $auth = eval { WebGUI::Pluggable::instanciate("WebGUI::Auth::".$authMethod, "new", [ $session, $authMethod ] ) }; if ($@) { # got an error $log->error($@); - $response->status( 500 ); # SERVER_ERROR + $session->response->status( 500 ); # SERVER_ERROR return; } elsif ($auth->authenticate($username, $password)) { # lets try to authenticate @@ -133,21 +131,35 @@ sub authen { } $session->{_var} = WebGUI::Session::Var->new($session, $sessionId); $session->user({user=>$user}); - $response->status( 200 ); # OK + $session->response->status( 200 ); # OK return; } } } $log->security($username." failed to login using HTTP Basic Authentication"); $request->note_basic_auth_failure; - $response->status( 401 ); # HTTP_UNAUTHORIZED; + $session->response->status( 401 ); # HTTP_UNAUTHORIZED return; } $log->info("BASIC AUTH: skipping"); - $response->status( 401 ); # HTTP_UNAUTHORIZED; + $session->response->status( 401 ); # HTTP_UNAUTHORIZED return; } +sub to_app { + my ( $self, $env ) = @_; + + # immediately starts the response and stream the content + return sub { + my $respond = shift; + my $writer = $respond->( [ 200, [ 'Content-Type', 'application/json' ] ] ); + + # IO bound delayed response + $writer->write( "hi there\n" ); + $writer->close; + }; +} + #------------------------------------------------------------------- =head2 run ( env ) @@ -164,7 +176,6 @@ sub run { my ($self, $env) = @_; my $request = Plack::Request->new( $env ); - my $response = $request->new_response( 200 ); my $config = WebGUI::Config->new( $self->root, $self->config ); my $matchUri = $request->uri; @@ -190,6 +201,7 @@ sub run { # set $repsonse->body (e.g. so they can set it to IO) -- they no longer return $output my $error = ""; my $gotMatch = 0; + my $response = $self->session->response; # TODO - would now be a time to fix the WEBGUI_FATAL label black magic? WEBGUI_FATAL: foreach my $handler (@{$config->get("urlHandlers")}) { diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index c10ec4ede..169ebf7ef 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -70,6 +70,7 @@ B It is important to distinguish the difference between a WebGUI session $session->os $session->privilege $session->request + $session->response $session->scratch $session->setting $session->stow @@ -457,7 +458,8 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config }; bless $self , $class; - $self->{_request} = $request if (defined $request); + $self->{_request} = $request if defined $request; + $self->{_response} = $request->new_response( 200 ) 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; @@ -541,7 +543,7 @@ sub quick { =head2 request ( ) -Returns the Plack::Request object, or undef if it doesn't exist. +Returns the L object, or undef if it doesn't exist. =cut @@ -552,6 +554,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. diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 2a141797a..fed19340e 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -258,7 +258,7 @@ 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, $datetime, $config, $var) = $self->session->quick(qw(request response datetime config var)); return undef unless $request; my $userId = $var->get("userId"); @@ -269,44 +269,44 @@ sub sendHeader { $self->setNoHeader(1); my %params; if ($self->isRedirect()) { - $request->new_response->header(Location => $self->getRedirectLocation); - $request->new_response->status($self->getStatus); + $response->header(Location => $self->getRedirectLocation); + $response->status($self->getStatus); } else { $request->content_type($self->getMimeType); my $cacheControl = $self->getCacheControl; my $date = ($userId eq "1") ? $datetime->epochToHttp($self->getLastModified) : $datetime->epochToHttp; # under these circumstances, don't allow caching if ($userId ne "1" || $cacheControl eq "none" || $self->session->setting->get("preventProxyCache")) { - $request->new_response->header("Cache-Control" => "private, max-age=1"); + $response->header("Cache-Control" => "private, max-age=1"); $request->no_cache(1); } # in all other cases, set cache, but tell it to ask us every time so we don't mess with recently logged in users else { - $request->new_response->header( 'Last-Modified' => $date); - $request->new_response->header( '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->new_response->header( 'Expires' => $date ); + $response->header( 'Expires' => $date ); } } if ($self->getFilename) { - $request->new_response->headers( 'Content-Disposition' => qq{attachment; filename="}.$self->getFilename().'"'); + $response->headers( 'Content-Disposition' => qq{attachment; filename="}.$self->getFilename().'"'); } - $request->new_response->status($self->getStatus()); -# $request->new_response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable + $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->new_response->header('Cache-Control' => 'private'); - $request->no_cache(1); - $request->response->status($self->getStatus()); -# $request->response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable + my $response = $self->session->response; + $response->content_type('text/html; charset=UTF-8'); + $response->header('Cache-Control' => 'private'); + $response->no_cache(1); + $response->status($self->getStatus()); +# $response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable return undef; } @@ -375,14 +375,12 @@ sub setCookie { my $domain = shift; $ttl = (defined $ttl ? $ttl : '+10y'); - if ($self->session->request) { - $self->session->request->new_response->cookies->{$name} = { - value => $value, - path => '/', - expires => $ttl ne 'session' ? $ttl : undef, - domain => $domain, - }; - } + $self->session->response->cookies->{$name} = { + value => $value, + path => '/', + expires => $ttl ne 'session' ? $ttl : undef, + domain => $domain, + }; } diff --git a/lib/WebGUI/Session/Output.pm b/lib/WebGUI/Session/Output.pm index a0bbcb884..84424690a 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -95,16 +95,18 @@ sub print { print $handle $content; } elsif ($self->session->request) { - # TODO - take away this hack - if (ref $self->session->request->body eq 'ARRAY') { - push @{$self->session->request->body}, $content; - } else { - if ($self->session->request->logger) { - $self->session->request->logger->({ level => 'warn', message => "dropping content: $content" }); - } else { - warn "dropping content: $content"; - } - } + # TODO - put in IO bound delayed response + warn "content: $content"; +# $self->session->request->body([]) unless $self->session->request->body(); +# if (ref $self->session->request->body eq 'ARRAY') { +# push @{$self->session->request->body}, $content; +# } else { +# if ($self->session->request->logger) { +# $self->session->request->logger->({ level => 'warn', message => "dropping content: $content" }); +# } else { +# warn "dropping content";#: $content"; +# } +# } # $self->session->request->print($content); } else { From 158124cf37ef8cf8d250d7d7d6b55c514a60a30b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 14 Mar 2010 20:41:22 -0400 Subject: [PATCH 18/92] mid-way commit --- etc/dev.localhost.localdomain.psgi | 26 +------- lib/Plack/Middleware/WebGUI.pm | 28 -------- lib/WebGUI.pm | 101 +++++++++++++++++++++++------ lib/WebGUI/Session.pm | 8 +-- lib/WebGUI/Session/Http.pm | 4 +- lib/WebGUI/URL/Content.pm | 4 ++ 6 files changed, 92 insertions(+), 79 deletions(-) delete mode 100644 lib/Plack/Middleware/WebGUI.pm diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index ff33e309b..144af28db 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -2,28 +2,6 @@ use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; -my $wg = WebGUI->new( - root => '/data/WebGUI', - config => 'dev.localhost.localdomain.conf', -); +my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' ); -builder { - - # Handle /extras via Plack::Middleware::Static - # (or Plack::Middleware::WebGUI could do this for us by looking up extrasPath and extrasURL in site.conf) -# enable 'Plack::Middleware::Static', -# path => '^' . $wg->config->get('extrasURL') . '/', -# root => $wg->config->get('extrasPath'); -# -# # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) -# # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) -# #enable 'Plack::Middleware::WGAccess', -# # path => '^' . $wg->config->get('uploadsURL') . '/', -# # root => $wg->config->get('uploadsPath'); -# -# enable 'Plack::Middleware::Static', -# path => '^' . $wg->config->get('uploadsURL') . '/', -# root => $wg->config->get('uploadsPath'); - - sub { $wg->run(@_) }; -} +$wg->psgi_app; \ No newline at end of file diff --git a/lib/Plack/Middleware/WebGUI.pm b/lib/Plack/Middleware/WebGUI.pm deleted file mode 100644 index 748f531f0..000000000 --- a/lib/Plack/Middleware/WebGUI.pm +++ /dev/null @@ -1,28 +0,0 @@ -package Plack::Middleware::WebGUI; -use strict; -use warnings; -use base qw/Plack::Middleware/; - -__PACKAGE__->mk_accessors('root', 'config'); - -=head1 NAME - -Plack::Middleware::WebGUI - -=head1 DESCRIPTION - -Plack Middleware that populates $env - -=cut - -sub call { - my $self = shift; - my $env = shift; - - $env->{'wg.WEBGUI_ROOT'} = $self->root; - $env->{'wg.WEBGUI_CONFIG'} = $self->config; - - $self->app->($env); -} - -1; \ No newline at end of file diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 75527b733..6fd8f6409 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -28,9 +28,12 @@ use WebGUI::User; use Moose; use Plack::Request; -has root => ( is => 'ro', required => 1 ); # WEBGUI_ROOT, e.g. /data/WebGUI -has config => ( is => 'ro', required => 1 ); # Site config, e.g. dev.localhost.localdomain.conf +has root => ( is => 'ro', isa => 'Str', required => 1 ); # e.g. /data/WebGUI +has site => ( is => 'ro', isa => 'Str', required => 1 ); # e.g. dev.localhost.localdomain.conf has session => ( is => 'rw', isa => 'WebGUI::Session' ); +has config => ( is => 'rw', isa => 'WebGUI::Config' ); + +use overload q(&{}) => sub { shift->psgi_app }, fallback => 1; =head1 NAME @@ -50,9 +53,32 @@ These subroutines are available from this package: =cut +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + + # Make constructor work as: + # WebGUI->new( $root, $site ) + # In addition to the more verbose: + # WebGUI->new( root => $root, site => $site ) + if (@_ eq 2) { + return $class->$orig(root => $_[0], site => $_[1] ); + } else { + return $class->$orig(@_); + } +}; + +sub BUILD { + my $self = shift; + + # Instantiate the WebGUI::Config object + my $config = WebGUI::Config->new( $self->root, $self->site ); + $self->config( $config ); +} + #------------------------------------------------------------------- -=head2 authen ( requestObject, [ user, pass, config ]) +=head2 authen ( requestObject, [ user, pass ]) HTTP Basic auth for WebGUI. @@ -68,14 +94,10 @@ The username to authenticate with. Will pull from the request object if not spec 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 ($self, $request, $username, $password, $config) = @_; + my ($self, $request, $username, $password) = @_; # # set username and password if it's an auth handler # if ($username eq "") { @@ -89,13 +111,13 @@ sub authen { # } # } - $config ||= WebGUI::Config->new( $self->root, $self->config ); + my $config = $self->config; # determine session id my $sessionId = $request->cookies->{$config->getCookieName}; # Instantiate the session object - my $session = $self->session( WebGUI::Session->open($self->root, $self->config, $request, $sessionId) ); + my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); my $log = $session->log; # $request->pnotes(wgSession => $session); # TODO - no more pnotes @@ -160,26 +182,63 @@ sub to_app { }; } +sub psgi_app { + my $self = shift; + return $self->{psgi_app} ||= $self->compile_psgi_app; +} + +sub compile_psgi_app { + my $self = shift; + + my $app = sub { + my $env = shift; + + my $request = Plack::Request->new( $env ); + my $response = $self->handle($request); + + return $response; + }; + + my $config = $self->config; + + # Extras + use Plack::Middleware::Static; + my $extrasURL = $config->get('extrasURL'); + my $extrasPath = $config->get('extrasPath'); + $app = Plack::Middleware::Static->wrap($app, + path => sub { s{^$extrasURL/}{} }, + root => "$extrasPath/", + ); + + # Uploads + my $uploadsURL = $config->get('uploadsURL'); + my $uploadsPath = $config->get('uploadsPath'); + $app = Plack::Middleware::Static->wrap($app, + path => sub { s{^$uploadsURL/}{} }, + root => "$uploadsPath/", + ); + + return $app; +} + #------------------------------------------------------------------- -=head2 run ( env ) +=head2 handle ( request ) Primary http init/response handler for WebGUI. This method decides whether to hand off the request to contentHandler() or uploadsHandler() -=head3 env +=head3 request -The PSGI environment hash +The Plack::Request object =cut -sub run { - my ($self, $env) = @_; +sub handle { + my ($self, $request) = @_; - my $request = Plack::Request->new( $env ); - my $config = WebGUI::Config->new( $self->root, $self->config ); - - my $matchUri = $request->uri; + my $config = $self->config; my $gateway = $config->get("gateway"); + my $matchUri = $request->uri; $matchUri =~ s{^$gateway}{/}; # handle basic auth @@ -187,12 +246,12 @@ sub run { if ($auth && $auth =~ m/^Basic/) { # machine oriented # Get username and password and hand over to authen $auth =~ s/Basic //; - $self->authen($request, split(":", MIME::Base64::decode_base64($auth), 2), $config); + $self->authen($request, split(":", MIME::Base64::decode_base64($auth), 2)); } else { # realm oriented # TODO - what to do here? Should we check response status after call to authen? # $request->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($request, undef, undef, $config)}); - $self->authen($request, undef, undef, $config); + $self->authen($request); } # url handlers diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 169ebf7ef..1b8d8733f 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -434,7 +434,7 @@ 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 @@ -453,10 +453,10 @@ Uses simple session vars. See WebGUI::Session::Var::new() for more details. sub open { my $class = shift; my $webguiRoot = shift; - my $configFile = shift; + my $c = shift; my $request = shift; - my $config = WebGUI::Config->new($webguiRoot,$configFile); - my $self = {_config=>$config }; + my $config = ref $c ? $c : WebGUI::Config->new($webguiRoot,$c); + my $self = {_config=>$config }; # TODO - if we store reference here, should we weaken WebGUI->config? bless $self , $class; $self->{_request} = $request if defined $request; $self->{_response} = $request->new_response( 200 ) if defined $request; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index fed19340e..2863460f6 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -278,7 +278,7 @@ sub sendHeader { # under these circumstances, don't allow caching if ($userId ne "1" || $cacheControl eq "none" || $self->session->setting->get("preventProxyCache")) { $response->header("Cache-Control" => "private, max-age=1"); - $request->no_cache(1); +# $request->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 { @@ -304,7 +304,7 @@ sub _sendMinimalHeader { my $response = $self->session->response; $response->content_type('text/html; charset=UTF-8'); $response->header('Cache-Control' => 'private'); - $response->no_cache(1); +# $response->no_cache(1); # TODO - re-enable this? $response->status($self->getStatus()); # $response->status_line($self->getStatus().' '.$self->getStatusDescription()); # TODO - re-enable return undef; diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 3116d1807..6d870f5ae 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -77,6 +77,10 @@ sub handler { $session->errorHandler->error( $@ ); } else { + if (defined $output) { + $session->response->body($output); + return; + } if ($output eq "chunked") { if ($session->errorHandler->canShowDebug()) { $session->output->print($session->errorHandler->showDebug(),1); From d858c6e1ab22fad7792a8509c9ab8abb326dac0f Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 14 Mar 2010 22:09:57 -0400 Subject: [PATCH 19/92] Demo site loads --- etc/dev.localhost.localdomain.psgi | 5 +- lib/WebGUI.pm | 221 +++++++---------------------- lib/WebGUI/Asset/Template.pm | 2 +- lib/WebGUI/Content/Asset.pm | 4 +- lib/WebGUI/Session/Output.pm | 3 +- lib/WebGUI/Session/Url.pm | 2 +- lib/WebGUI/URL/Content.pm | 87 ++++++------ t/Asset/Template.t | 2 +- 8 files changed, 99 insertions(+), 227 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 144af28db..2ffcee8a4 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,7 +1,4 @@ -use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; -my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' ); - -$wg->psgi_app; \ No newline at end of file +my $app = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' )->psgi_app; \ No newline at end of file diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 6fd8f6409..d0a934ed1 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -76,112 +76,6 @@ sub BUILD { $self->config( $config ); } -#------------------------------------------------------------------- - -=head2 authen ( requestObject, [ user, pass ]) - -HTTP Basic auth for WebGUI. - -=head3 requestObject - -The Plack::Request object instantiated from the PSGI env hash - -=head3 user - -The username to authenticate with. Will pull from the request object if not specified. - -=head3 pass - -The password to authenticate with. Will pull from the request object if not specified. - -=cut - -sub authen { - my ($self, $request, $username, $password) = @_; - -# # 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; # TODO - don't think this is supported by Plack::Request -# $username = $request->user; -# } -# else { -# $response->status( 401 ); # HTTP_UNAUTHORIZED; -# return; -# } -# } - - my $config = $self->config; - - # determine session id - my $sessionId = $request->cookies->{$config->getCookieName}; - - # Instantiate the session object - my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); - my $log = $session->log; -# $request->pnotes(wgSession => $session); # TODO - no more pnotes - - if (defined $sessionId && $session->user->isRegistered) { # got a session id passed in or from a cookie - $log->info("BASIC AUTH: using cookie"); - $session->response->status( 200 ); # OK - return; - } - # TODO - put this back in once we figure out get_basic_auth_pw -# elsif ($status != 200) { # 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($@); - $session->response->status( 500 ); # SERVER_ERROR - return; - } - 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}); - $session->response->status( 200 ); # OK - return; - } - } - } - $log->security($username." failed to login using HTTP Basic Authentication"); - $request->note_basic_auth_failure; - $session->response->status( 401 ); # HTTP_UNAUTHORIZED - return; - } - $log->info("BASIC AUTH: skipping"); - $session->response->status( 401 ); # HTTP_UNAUTHORIZED - return; -} - -sub to_app { - my ( $self, $env ) = @_; - - # immediately starts the response and stream the content - return sub { - my $respond = shift; - my $writer = $respond->( [ 200, [ 'Content-Type', 'application/json' ] ] ); - - # IO bound delayed response - $writer->write( "hi there\n" ); - $writer->close; - }; -} - sub psgi_app { my $self = shift; return $self->{psgi_app} ||= $self->compile_psgi_app; @@ -189,13 +83,11 @@ sub psgi_app { sub compile_psgi_app { my $self = shift; - + my $app = sub { my $env = shift; - - my $request = Plack::Request->new( $env ); - my $response = $self->handle($request); - + my $request = Plack::Request->new($env); # This could also be WebGUI::Request + my $response = $self->dispatch($request); return $response; }; @@ -215,79 +107,64 @@ sub compile_psgi_app { my $uploadsPath = $config->get('uploadsPath'); $app = Plack::Middleware::Static->wrap($app, path => sub { s{^$uploadsURL/}{} }, - root => "$uploadsPath/", + root => "$uploadsPath/", ); return $app; } -#------------------------------------------------------------------- - -=head2 handle ( request ) - -Primary http init/response handler for WebGUI. This method decides whether to hand off the request to contentHandler() or uploadsHandler() - -=head3 request - -The Plack::Request object - -=cut - -sub handle { - my ($self, $request) = @_; +sub dispatch { + my ( $self, $request ) = @_; - my $config = $self->config; - my $gateway = $config->get("gateway"); - my $matchUri = $request->uri; - $matchUri =~ s{^$gateway}{/}; + my $config = $self->config; + + # determine session id + my $sessionId = $request->cookies->{$config->getCookieName}; - # handle basic auth - my $auth = $request->header('Authorization'); - if ($auth && $auth =~ m/^Basic/) { # machine oriented - # Get username and password and hand over to authen - $auth =~ s/Basic //; - $self->authen($request, split(":", MIME::Base64::decode_base64($auth), 2)); - } - else { # realm oriented - # TODO - what to do here? Should we check response status after call to authen? -# $request->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($request, undef, undef, $config)}); - $self->authen($request); - } - - # url handlers - # TODO - rip out urlHandler API - convert all to middleware - # all remaining url handlers (probably just Asset which might get converted to something else) should - # set $repsonse->body (e.g. so they can set it to IO) -- they no longer return $output - my $error = ""; - my $gotMatch = 0; - my $response = $self->session->response; - - # TODO - would now be a time to fix the WEBGUI_FATAL label black magic? - WEBGUI_FATAL: foreach my $handler (@{$config->get("urlHandlers")}) { - my ($regex) = keys %{$handler}; - if ($matchUri =~ m{$regex}i) { - eval { WebGUI::Pluggable::run($handler->{$regex}, "handler", [$request, $self->session]) }; - if ($@) { - $error = $@; + # Instantiate the session object + my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); + + for 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 { + # 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" )) { + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } last; } - else { - # Record that at least one url handler ran successfully - $gotMatch = 1; - - # But only return response if body was set - if (defined $response->body ) { # or maybe get a smarter way for url handlers to flag success - b/c this may break delayed IO - return $response->finalize; - } + # non-empty output should be used as the response body + elsif (defined $output && $output ne "") { + # Auto-set the headers + $session->http->sendHeader; # TODO: should be renamed setHeader + + # Use contentHandler's return value as the output + $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; } } - } - - if ( !$gotMatch ) { - # can't handle the url due to error or misconfiguration - $response->body( "This server is unable to handle the url '".$request->uri."' that you requested. ".$error ); } - return $response->finalize; + $session->close; + + return $session->response->finalize; } 1; diff --git a/lib/WebGUI/Asset/Template.pm b/lib/WebGUI/Asset/Template.pm index 646cd8571..21e4144be 100644 --- a/lib/WebGUI/Asset/Template.pm +++ b/lib/WebGUI/Asset/Template.pm @@ -589,7 +589,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/Content/Asset.pm b/lib/WebGUI/Content/Asset.pm index 2eb9074dc..6ea455947 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 @@ -131,7 +129,7 @@ sub handler { 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/Session/Output.pm b/lib/WebGUI/Session/Output.pm index 84424690a..89640757f 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -96,8 +96,7 @@ sub print { } elsif ($self->session->request) { # TODO - put in IO bound delayed response - warn "content: $content"; -# $self->session->request->body([]) unless $self->session->request->body(); + $self->session->response->body( $self->session->response->body() . $content ); # if (ref $self->session->request->body eq 'ARRAY') { # push @{$self->session->request->body}, $content; # } else { diff --git a/lib/WebGUI/Session/Url.pm b/lib/WebGUI/Session/Url.pm index fe6a2daf1..1f5e470e9 100644 --- a/lib/WebGUI/Session/Url.pm +++ b/lib/WebGUI/Session/Url.pm @@ -322,7 +322,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/; } diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 6d870f5ae..14a2d8fd4 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -15,6 +15,7 @@ package WebGUI::URL::Content; =cut use strict; +use Apache2::Const -compile => qw(OK DECLINED); use WebGUI::Affiliate; use WebGUI::Exception; use WebGUI::Pluggable; @@ -41,7 +42,7 @@ These subroutines are available from this package: #------------------------------------------------------------------- -=head2 handler ( request, session ) +=head2 handler ( request, server, config ) The Apache request handler for this package. @@ -60,55 +61,55 @@ to the user, instead of displaying the Page Not Found page. =cut sub handler { - my ($request, $session) = @_; - my $config = $session->config; -# my $session = $request->pnotes('wgSession'); # TODO - no more pnotes -# unless (defined $session) { - # TODO - fix this - server is gone -# $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); -# } - WEBGUI_FATAL: 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); + my ($request, $server, $config) = @_; + $request->push_handlers(PerlResponseHandler => sub { + my $session = $request->pnotes('wgSession'); + unless (defined $session) { + $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); } - elsif ( $@ ) { - $session->errorHandler->error( $@ ); - } - else { - if (defined $output) { - $session->response->body($output); - return; + WEBGUI_FATAL: 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); } - if ($output eq "chunked") { - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); + elsif ( $@ ) { + $session->errorHandler->error( $@ ); + } + else { + if ($output eq "chunked") { + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } + last; } - last; - } - if ($output eq "empty") { - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); + if ($output eq "empty") { + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } + last; } - last; - } - elsif (defined $output && $output ne "") { - $session->http->sendHeader; - $session->output->print($output); - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); + 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; } - last; - } - # Keep processing for success codes - elsif ($session->http->getStatus < 200 || $session->http->getStatus > 299) { - $session->http->sendHeader; - last; } } - } - $session->close; + $session->close; + 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/t/Asset/Template.t b/t/Asset/Template.t index e4bc81e23..4ee633ec4 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 ) }; From 5d4e0f95d79ea560d59be43886a6dd10d9157c67 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 16 Mar 2010 23:26:50 -0400 Subject: [PATCH 20/92] WebGUI is now a one-liner ;) --- lib/WebGUI.pm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index d0a934ed1..b9cf47853 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -28,8 +28,8 @@ use WebGUI::User; use Moose; use Plack::Request; -has root => ( is => 'ro', isa => 'Str', required => 1 ); # e.g. /data/WebGUI -has site => ( is => 'ro', isa => 'Str', required => 1 ); # e.g. dev.localhost.localdomain.conf +has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); +has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); has session => ( is => 'rw', isa => 'WebGUI::Session' ); has config => ( is => 'rw', isa => 'WebGUI::Config' ); @@ -58,11 +58,11 @@ around BUILDARGS => sub { my $class = shift; # Make constructor work as: - # WebGUI->new( $root, $site ) + # WebGUI->new( $site ) # In addition to the more verbose: # WebGUI->new( root => $root, site => $site ) - if (@_ eq 2) { - return $class->$orig(root => $_[0], site => $_[1] ); + if (@_ eq 1) { + return $class->$orig(site => $_[0] ); } else { return $class->$orig(@_); } @@ -167,4 +167,7 @@ sub dispatch { return $session->response->finalize; } -1; +no Moose; +__PACKAGE__->meta->make_immutable; + +1; \ No newline at end of file From e15c32e3f75b1af5c282ceccd956301720c1e92f Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 16 Mar 2010 23:35:13 -0400 Subject: [PATCH 21/92] Added benchmark script for NYTProf-ing --- benchmark.pl | 14 ++++++++++++++ etc/dev.localhost.localdomain.psgi | 10 +++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) create mode 100755 benchmark.pl diff --git a/benchmark.pl b/benchmark.pl new file mode 100755 index 000000000..329a95c7b --- /dev/null +++ b/benchmark.pl @@ -0,0 +1,14 @@ +# 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 HTTP::Request::Common; +my $app = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' )->psgi_app; + +test_psgi $app, sub { + my $cb = shift; + my $res = $cb->( GET "/" ); +} for 1..100; diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 2ffcee8a4..6306850cc 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,4 +1,12 @@ use lib '/data/WebGUI/lib'; use WebGUI; -my $app = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' )->psgi_app; \ No newline at end of file +# 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; +# Or equivalently (using the defaults): +WebGUI->new; \ No newline at end of file From 2516ff12c14bc81f10d020889b9e1843105127b5 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Thu, 18 Mar 2010 21:38:20 -0400 Subject: [PATCH 22/92] Added URLMap support (e.g. virtual hosts and mounting) --- .../basic.psgi | 0 eg/urlmap.psgi | 20 +++++++++++++++++++ lib/WebGUI/Asset.pm | 8 ++++---- lib/WebGUI/Asset/Wobject/ProjectManager.pm | 12 +++++------ lib/WebGUI/Asset/Wobject/TimeTracking.pm | 6 +++--- lib/WebGUI/AssetExportHtml.pm | 4 ++-- lib/WebGUI/Macro/FilePump.pm | 4 ++-- lib/WebGUI/Macro/Widget.pm | 2 +- lib/WebGUI/Session/Url.pm | 18 ++++++++++++++--- lib/WebGUI/Storage.pm | 2 +- 10 files changed, 54 insertions(+), 22 deletions(-) rename etc/dev.localhost.localdomain.psgi => eg/basic.psgi (100%) create mode 100644 eg/urlmap.psgi diff --git a/etc/dev.localhost.localdomain.psgi b/eg/basic.psgi similarity index 100% rename from etc/dev.localhost.localdomain.psgi rename to eg/basic.psgi 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/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 565d27bf3..6b67ba6ad 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -742,8 +742,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 @@ -1970,7 +1970,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. @@ -2072,7 +2072,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/Wobject/ProjectManager.pm b/lib/WebGUI/Asset/Wobject/ProjectManager.pm index fa4730997..5b73a9d13 100644 --- a/lib/WebGUI/Asset/Wobject/ProjectManager.pm +++ b/lib/WebGUI/Asset/Wobject/ProjectManager.pm @@ -741,7 +741,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"); @@ -904,7 +904,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"; @@ -1494,8 +1494,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'); @@ -1726,8 +1726,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 e53528e98..128f5825f 100644 --- a/lib/WebGUI/Asset/Wobject/TimeTracking.pm +++ b/lib/WebGUI/Asset/Wobject/TimeTracking.pm @@ -185,7 +185,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"); @@ -337,7 +337,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 @@ -509,7 +509,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 b267b8868..4ba566d8a 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -636,9 +636,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/Macro/FilePump.pm b/lib/WebGUI/Macro/FilePump.pm index d8312b310..058d3842b 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/Session/Url.pm b/lib/WebGUI/Session/Url.pm index 1f5e470e9..17000762d 100644 --- a/lib/WebGUI/Session/Url.pm +++ b/lib/WebGUI/Session/Url.pm @@ -144,7 +144,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 +190,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).':'.$self->session->datetime->time()); @@ -198,7 +198,19 @@ sub gateway { if ($pairs) { $url = $self->append($url,$pairs); } - return $url; + + return $url; +} + +# Temporary hack +sub make_urlmap_work { + my $self = shift; + my $url = shift; + my $uri = $self->session->request->base; + $uri->path($uri->path . $url); + my $path = $uri->path; + $path =~ s{^//}{/}; + return $path; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Storage.pm b/lib/WebGUI/Storage.pm index c07dbd7f0..fafa38596 100644 --- a/lib/WebGUI/Storage.pm +++ b/lib/WebGUI/Storage.pm @@ -1265,7 +1265,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'} From 72017cf83f2b76ff337e96b8ddb972806cf5650b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 19:35:06 -0400 Subject: [PATCH 23/92] Added WebGUI::Requestion/Response --- README | 11 +++++++ .../Plack.pm => WebGUI-Session-Plack.pm | 2 ++ lib/WebGUI.pm | 16 +++++----- lib/WebGUI/Request.pm | 29 +++++++++++++++++++ lib/WebGUI/Response.pm | 10 +++++++ 5 files changed, 60 insertions(+), 8 deletions(-) create mode 100644 README rename lib/WebGUI/Session/Plack.pm => WebGUI-Session-Plack.pm (97%) create mode 100644 lib/WebGUI/Request.pm create mode 100644 lib/WebGUI/Response.pm diff --git a/README b/README new file mode 100644 index 000000000..f37e9ba14 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +This is the PSGI branch of WebGUI8 + +Currently, the best performance is achieved via: + + plackup eg/basic.psgi -E none -s Starman --workers 10 + +You can benchmark your server via: + + ab -t 3 -c 10 -k http://dev.localhost.localdomain:5000/ | grep Req + +I'm currently getting 20 requests/second, whereas I'm getting 30/second on the non-PSGI WebGUI8 branch. \ No newline at end of file diff --git a/lib/WebGUI/Session/Plack.pm b/WebGUI-Session-Plack.pm similarity index 97% rename from lib/WebGUI/Session/Plack.pm rename to WebGUI-Session-Plack.pm index c60f04aa8..411f6775c 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/WebGUI-Session-Plack.pm @@ -1,5 +1,7 @@ package WebGUI::Session::Plack; +# This file is deprecated - keeping it here for reference until everything has been ported + use strict; use warnings; use Carp; diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index b9cf47853..96e5dd230 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -25,8 +25,8 @@ use WebGUI::Config; use WebGUI::Pluggable; use WebGUI::Session; use WebGUI::User; +use WebGUI::Request; use Moose; -use Plack::Request; has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); @@ -69,11 +69,11 @@ around BUILDARGS => sub { }; sub BUILD { - my $self = shift; - - # Instantiate the WebGUI::Config object - my $config = WebGUI::Config->new( $self->root, $self->site ); - $self->config( $config ); + my $self = shift; + + # Instantiate the WebGUI::Config object + my $config = WebGUI::Config->new( $self->root, $self->site ); + $self->config($config); } sub psgi_app { @@ -86,7 +86,7 @@ sub compile_psgi_app { my $app = sub { my $env = shift; - my $request = Plack::Request->new($env); # This could also be WebGUI::Request + my $request = WebGUI::Request->new($env); my $response = $self->dispatch($request); return $response; }; @@ -119,7 +119,7 @@ sub dispatch { my $config = $self->config; # determine session id - my $sessionId = $request->cookies->{$config->getCookieName}; + my $sessionId = $request->cookies->{$config->getCookieName}; # Instantiate the session object my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); diff --git a/lib/WebGUI/Request.pm b/lib/WebGUI/Request.pm new file mode 100644 index 000000000..873462102 --- /dev/null +++ b/lib/WebGUI/Request.pm @@ -0,0 +1,29 @@ +package WebGUI::Request; + +=head2 DESCRIPTION + +The WebGUI server response object. See L + +=cut + +use parent qw(Plack::Request); +use WebGUI::Response; + +=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; + WebGUI::Response->new(@_); +} + +1; \ No newline at end of file diff --git a/lib/WebGUI/Response.pm b/lib/WebGUI/Response.pm new file mode 100644 index 000000000..e57bd1303 --- /dev/null +++ b/lib/WebGUI/Response.pm @@ -0,0 +1,10 @@ +package WebGUI::Response; +use parent qw(Plack::Response); + +=head2 DESCRIPTION + +The WebGUI server response object. See of L + +=cut + +1; \ No newline at end of file From 68bbca1808e03ff2ddd3f34c2f821b1a6655742d Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 20:02:33 -0400 Subject: [PATCH 24/92] Started deprecating WebGUI::Session::Http --- TODO | 9 +++++++++ lib/WebGUI.pm | 2 +- lib/WebGUI/Session.pm | 2 +- lib/WebGUI/Session/Http.pm | 11 +++++++++-- 4 files changed, 20 insertions(+), 4 deletions(-) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 000000000..909e8370b --- /dev/null +++ b/TODO @@ -0,0 +1,9 @@ +TODO +* Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response +* Turn logger into $self->request->env->{'psgi.errors'}->print(join '', @stuff); + +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 \ No newline at end of file diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 96e5dd230..f8b6eef09 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -162,8 +162,8 @@ sub dispatch { } } } + $session->close; - return $session->response->finalize; } diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 1b8d8733f..43dc23601 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -460,7 +460,7 @@ sub open { bless $self , $class; $self->{_request} = $request if defined $request; $self->{_response} = $request->new_response( 200 ) if defined $request; - my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; + my $sessionId = shift || $request->cookies->{$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); diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 2863460f6..313486fc8 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -18,6 +18,12 @@ package WebGUI::Session::Http; use strict; use WebGUI::Utility; +sub _deprecated { + my $alt = shift; + my $method = (caller(1))[3]; + Carp::carp("$method is deprecated. Use 'WebGUI::$alt' instead."); +} + =head1 NAME Package WebGUI::Session::Http @@ -91,7 +97,8 @@ Retrieves the cookies from the HTTP header and returns a hash reference containi sub getCookies { my $self = shift; - return $self->session->request ? $self->session->request->cookies : {}; + _deprecated('Request::cookies'); + return $self->session->request->cookies; } @@ -264,7 +271,7 @@ sub sendHeader { # 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; From a866fd10f0cd694a4b58845d0bf629120895d017 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 20:05:07 -0400 Subject: [PATCH 25/92] Added contentHandlers short-circuit for benchmarking PSGI vs. modperl --- lib/WebGUI.pm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index f8b6eef09..21531008e 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -124,6 +124,11 @@ sub dispatch { # Instantiate the session object my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); + # Short-circuit contentHandlers - for benchmarking PSGI scaffolding vs. modperl + $session->close; + $session->output->print('WebGUI PSGI with contentHandlers short-circuited for benchmarking'); + return $session->response->finalize; + for my $handler (@{$config->get("contentHandlers")}) { my $output = eval { WebGUI::Pluggable::run($handler, "handler", [ $session ] )}; if ( my $e = WebGUI::Error->caught ) { From 191d4fc4013806a2e536bc74ea45919e5225e986 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 20:56:49 -0400 Subject: [PATCH 26/92] Started refactoring output --- TODO | 1 + lib/WebGUI/Session/Output.pm | 31 +++++++++++-------------------- 2 files changed, 12 insertions(+), 20 deletions(-) diff --git a/TODO b/TODO index 909e8370b..3ee21a684 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,7 @@ TODO * Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response * Turn logger into $self->request->env->{'psgi.errors'}->print(join '', @stuff); +* Remove WebGUI::Session::Output DONE * $session->request is now a Plack::Request object diff --git a/lib/WebGUI/Session/Output.pm b/lib/WebGUI/Session/Output.pm index 89640757f..98dcbea63 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -90,27 +90,18 @@ sub print { my $content = shift; my $skipMacros = shift || !($self->session->http->getMimeType =~ /^text/); WebGUI::Macro::process($self->session, \$content) unless $skipMacros; - my $handle = $self->{_handle}; - if (defined $handle) { - print $handle $content; - } - elsif ($self->session->request) { - # TODO - put in IO bound delayed response - $self->session->response->body( $self->session->response->body() . $content ); -# if (ref $self->session->request->body eq 'ARRAY') { -# push @{$self->session->request->body}, $content; -# } else { -# if ($self->session->request->logger) { -# $self->session->request->logger->({ level => 'warn', message => "dropping content: $content" }); -# } else { -# warn "dropping content";#: $content"; -# } -# } -# $self->session->request->print($content); - } - else { - print $content; + + # Initialise response body if it's empty + $self->session->response->body([]) if !$self->session->response->body; + + my $body = $self->session->response->body; + if (ref $body ne 'ARRAY') { + Carp::carp("Response body is not an ARRAY, it's a " . ref $body); + return; } + push @{ $body }, $content; + + # TODO - put in IO bound delayed response } #------------------------------------------------------------------- From 217b486b0357cf969b8f0ec52ba1078f53e28873 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 21:00:56 -0400 Subject: [PATCH 27/92] Delayed response --- lib/WebGUI.pm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 21531008e..c7f89d42e 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -86,9 +86,13 @@ sub compile_psgi_app { my $app = sub { my $env = shift; - my $request = WebGUI::Request->new($env); - my $response = $self->dispatch($request); - return $response; + + return sub { + my $callback = shift; + my $request = WebGUI::Request->new($env); + my $response = $self->dispatch($request); + $callback->($response); + } }; my $config = $self->config; From 9e535846d50cdd72ce8f7a20fe15b7d98693adfd Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 21:57:57 -0400 Subject: [PATCH 28/92] Adds support for streaming response body --- lib/WebGUI.pm | 41 +++++++++++++++++++++++++++++++++++++---- lib/WebGUI/Response.pm | 9 +++++++++ 2 files changed, 46 insertions(+), 4 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index c7f89d42e..d2d2b9887 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -27,6 +27,7 @@ use WebGUI::Session; use WebGUI::User; use WebGUI::Request; use Moose; +use Try::Tiny; has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); @@ -91,7 +92,26 @@ sub compile_psgi_app { my $callback = shift; my $request = WebGUI::Request->new($env); my $response = $self->dispatch($request); - $callback->($response); + + if (ref $response eq 'ARRAY' && ref $response->[2] eq 'CODE') { + # Response wants to stream itself, so tell PSGI server to give us + # a streaming writer object + my $writer = $callback->( [ $response->[0], $response->[1] ] ); + + # ..and let the response stream itself + try { + $response->[2]->($writer); + } catch { + # Response has already been started, so log error and close writer + warn "error caught after streaming response started"; + $writer->close; + } + } 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. + $callback->($response); + } } }; @@ -129,9 +149,22 @@ sub dispatch { my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); # Short-circuit contentHandlers - for benchmarking PSGI scaffolding vs. modperl - $session->close; - $session->output->print('WebGUI PSGI with contentHandlers short-circuited for benchmarking'); - return $session->response->finalize; +# $session->close; +# $session->output->print("WebGUI PSGI with contentHandlers short-circuited for benchmarking\n"); +# return $session->response->finalize; + + # Streaming content + $session->response->stream(sub { + my $writer = shift; + $writer->write("WebGUI PSGI with contentHandlers short-circuited for benchmarking (streaming)\n"); +# sleep 1; + $writer->write("...see?\n"); + $writer->close; + }); + if ($session->response->streaming) { + $session->close; + return $session->response->finalize; + } for my $handler (@{$config->get("contentHandlers")}) { my $output = eval { WebGUI::Pluggable::run($handler, "handler", [ $session ] )}; diff --git a/lib/WebGUI/Response.pm b/lib/WebGUI/Response.pm index e57bd1303..07dce8806 100644 --- a/lib/WebGUI/Response.pm +++ b/lib/WebGUI/Response.pm @@ -1,10 +1,19 @@ package WebGUI::Response; use parent qw(Plack::Response); +use Plack::Util::Accessor qw(streaming); + =head2 DESCRIPTION The WebGUI server response object. See of L =cut +sub stream { + my $self = shift; + my $streamer = shift; + $self->streaming(1); + $self->body($streamer); +} + 1; \ No newline at end of file From c0abcc3e4af06854cc7634fc056ded32ee9dff22 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 6 Apr 2010 22:48:41 -0400 Subject: [PATCH 29/92] checkpoint --- lib/WebGUI.pm | 73 ++++++++++++++++++++++++++---------- lib/WebGUI/Response.pm | 14 ++++++- lib/WebGUI/Session/Output.pm | 24 ++++++------ 3 files changed, 78 insertions(+), 33 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index d2d2b9887..2337566f3 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -91,26 +91,44 @@ sub compile_psgi_app { return sub { my $callback = shift; my $request = WebGUI::Request->new($env); - my $response = $self->dispatch($request); + my $res = $self->dispatch($request); - if (ref $response eq 'ARRAY' && ref $response->[2] eq 'CODE') { - # Response wants to stream itself, so tell PSGI server to give us - # a streaming writer object - my $writer = $callback->( [ $response->[0], $response->[1] ] ); + if ( ref $res eq 'WebGUI::Session' ) { + my $session = $res; + my $response = $session->response; - # ..and let the response stream itself try { - $response->[2]->($writer); - } catch { - # Response has already been started, so log error and close writer - warn "error caught after streaming response started"; + # Response wants to stream itself, so ask PSGI server for a + # streaming writer object by returning the PSGI response, minus the body + + # Anything in the response body gets cleared (should be empty anyway) + $response->body([]); + my $psgi_response = $response->finalize; + + my $writer = $callback->( [ $psgi_response->[0], $psgi_response->[1] ] ); + + # Store the writer object in the WebGUI::Response object + $response->writer($writer); + + # ..and let the response stream itself + $response->streamer->($session); + $writer->close; + $session->close; + } catch { + if ($response->writer) { + # Response has already been started, so log error and close writer + warn "error caught after streaming response started"; + $response->writer->close; + } else { + $callback->( [ 500, [ 'Content-type: text/html' ], [ 'An error occurred' ] ] ); + } } } 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. - $callback->($response); + $callback->($res); } } }; @@ -152,18 +170,33 @@ sub dispatch { # $session->close; # $session->output->print("WebGUI PSGI with contentHandlers short-circuited for benchmarking\n"); # return $session->response->finalize; + + # TODO: From here, contentHandlers need to decide if they want to stream the response body: + # $session->response->stream( sub { ... } ) # this replaces 'chunked' + # or return a psgi response body. + # + # We use the $session->response->streaming flag to detect if a contentHandler has requested + # to use streaming response. + # + # Otherwise, whatever they return (arrayref or IO::Handle) is used as the psgi response + # + # Regular assets should use streaming response body, unless they want to send a file - # Streaming content + # Here's an example of what a contentHandler would call to do a streaming response: $session->response->stream(sub { - my $writer = shift; - $writer->write("WebGUI PSGI with contentHandlers short-circuited for benchmarking (streaming)\n"); -# sleep 1; - $writer->write("...see?\n"); - $writer->close; + my $session = shift; + $session->output->print("WebGUI PSGI with contentHandlers short-circuited for benchmarking (streaming)\n"); + sleep 1; + $session->output->print("...see?\n"); }); - if ($session->response->streaming) { - $session->close; - return $session->response->finalize; + + # Afterwards, we check $session->response->streaming, and if it is set, return the + # WebGUI::Session (since our caller doesn't have a reference to it) TODO - or does it via $request->session->response??? + + # TODO: give WebGUI::Req/Res a weak session reference + + if ( $session->response->streaming ) { + return $session; } for my $handler (@{$config->get("contentHandlers")}) { diff --git a/lib/WebGUI/Response.pm b/lib/WebGUI/Response.pm index 07dce8806..dbd3a29dc 100644 --- a/lib/WebGUI/Response.pm +++ b/lib/WebGUI/Response.pm @@ -1,7 +1,8 @@ package WebGUI::Response; +use strict; use parent qw(Plack::Response); -use Plack::Util::Accessor qw(streaming); +use Plack::Util::Accessor qw(streaming writer streamer); =head2 DESCRIPTION @@ -13,7 +14,16 @@ sub stream { my $self = shift; my $streamer = shift; $self->streaming(1); - $self->body($streamer); + $self->streamer($streamer); +} + +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/Output.pm b/lib/WebGUI/Session/Output.pm index 98dcbea63..82e31d09e 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -90,18 +90,20 @@ sub print { my $content = shift; my $skipMacros = shift || !($self->session->http->getMimeType =~ /^text/); WebGUI::Macro::process($self->session, \$content) unless $skipMacros; - - # Initialise response body if it's empty - $self->session->response->body([]) if !$self->session->response->body; - - my $body = $self->session->response->body; - if (ref $body ne 'ARRAY') { - Carp::carp("Response body is not an ARRAY, it's a " . ref $body); - return; + my $handle = $self->{_handle}; + if (defined $handle) { + print $handle $content; + } + elsif ($self->session->response) { + if ($self->session->response->streaming) { + $self->session->response->stream_write($content); + } else { + + } + } + else { + print $content; } - push @{ $body }, $content; - - # TODO - put in IO bound delayed response } #------------------------------------------------------------------- From c7235378d1248b579084a4de0a295269df9ef5f2 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Wed, 7 Apr 2010 01:02:01 -0400 Subject: [PATCH 30/92] Streaming response API for contentHandlers is now taking shape --- lib/WebGUI.pm | 140 +++++++++++++++++++---------------- lib/WebGUI/Request.pm | 6 +- lib/WebGUI/Response.pm | 5 +- lib/WebGUI/Session.pm | 7 +- lib/WebGUI/Session/Output.pm | 10 ++- 5 files changed, 94 insertions(+), 74 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 2337566f3..fe116d57b 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -31,7 +31,6 @@ use Try::Tiny; has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); -has session => ( is => 'rw', isa => 'WebGUI::Session' ); has config => ( is => 'rw', isa => 'WebGUI::Config' ); use overload q(&{}) => sub { shift->psgi_app }, fallback => 1; @@ -75,60 +74,86 @@ sub BUILD { # Instantiate the WebGUI::Config object my $config = WebGUI::Config->new( $self->root, $self->site ); $self->config($config); -} +} sub psgi_app { my $self = shift; return $self->{psgi_app} ||= $self->compile_psgi_app; } +sub new_session { + my $self = shift; + my $request = shift; + + # determine session id + my $sessionId = $request->cookies->{$self->config->getCookieName}; + + # Instantiate the session object + return WebGUI::Session->open($self->root, $self->config, $request, $sessionId); +} + sub compile_psgi_app { my $self = shift; + my $catch = [ 500, [ 'Content-Type' => 'text/plain' ], [ "Internal Server Error\n" ] ]; + my $app = sub { my $env = shift; + my $log = sub { + $env->{'psgi.errors'}->print(join '', @_, "\n"); + }; + return sub { my $callback = shift; my $request = WebGUI::Request->new($env); - my $res = $self->dispatch($request); + my $session = $self->new_session($request); - if ( ref $res eq 'WebGUI::Session' ) { - my $session = $res; - my $response = $session->response; + try { + $self->handle($request); + } catch { + $log->( "Error handling request: $_" ); + $callback->( $catch ); + return; + }; + + my $response = $session->response; + my $psgi_response = $response->finalize; + + if ( $response->streaming ) { try { - # Response wants to stream itself, so ask PSGI server for a - # streaming writer object by returning the PSGI response, minus the body - - # Anything in the response body gets cleared (should be empty anyway) - $response->body([]); - my $psgi_response = $response->finalize; - + # Ask PSGI server for a streaming writer object by returning a 2-part + # arrayref instead of a 3-part array my $writer = $callback->( [ $psgi_response->[0], $psgi_response->[1] ] ); # Store the writer object in the WebGUI::Response object $response->writer($writer); - # ..and let the response stream itself + # Now call the callback that does the streaming $response->streamer->($session); + # And finally, clean up $writer->close; - $session->close; + } catch { if ($response->writer) { # Response has already been started, so log error and close writer - warn "error caught after streaming response started"; + $log->("Error detected after streaming response started"); $response->writer->close; } else { - $callback->( [ 500, [ 'Content-type: text/html' ], [ 'An error occurred' ] ] ); + $callback->( $catch ); } - } + } finally { + $session->close; + }; } 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. - $callback->($res); + $session->close; + $callback->($psgi_response); } } }; @@ -153,53 +178,35 @@ sub compile_psgi_app { ); return $app; -} +} -sub dispatch { +sub handle { my ( $self, $request ) = @_; - my $config = $self->config; + my $session = $request->session; - # determine session id - my $sessionId = $request->cookies->{$config->getCookieName}; - - # Instantiate the session object - my $session = $self->session( WebGUI::Session->open($self->root, $config, $request, $sessionId) ); - - # Short-circuit contentHandlers - for benchmarking PSGI scaffolding vs. modperl -# $session->close; + # 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 $session->response->finalize; +# return; - # TODO: From here, contentHandlers need to decide if they want to stream the response body: - # $session->response->stream( sub { ... } ) # this replaces 'chunked' - # or return a psgi response body. - # - # We use the $session->response->streaming flag to detect if a contentHandler has requested - # to use streaming response. - # - # Otherwise, whatever they return (arrayref or IO::Handle) is used as the psgi response - # - # Regular assets should use streaming response body, unless they want to send a file + # 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. + + # 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; - # Here's an example of what a contentHandler would call to do 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"); - }); - - # Afterwards, we check $session->response->streaming, and if it is set, return the - # WebGUI::Session (since our caller doesn't have a reference to it) TODO - or does it via $request->session->response??? - - # TODO: give WebGUI::Req/Res a weak session reference - - if ( $session->response->streaming ) { - return $session; - } - - for my $handler (@{$config->get("contentHandlers")}) { + # TODO: refactor the following loop, find all instances of "chunked" and "empty" in codebase, etc.. + for my $handler (@{$self->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); @@ -209,14 +216,19 @@ sub dispatch { $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"; if ($session->errorHandler->canShowDebug()) { $session->output->print($session->errorHandler->showDebug(),1); } - last; + return; } # non-empty output should be used as the response body elsif (defined $output && $output ne "") { @@ -228,18 +240,16 @@ sub dispatch { if ($session->errorHandler->canShowDebug()) { $session->output->print($session->errorHandler->showDebug(),1); } - last; + return; } # Keep processing for success codes elsif ($session->http->getStatus < 200 || $session->http->getStatus > 299) { $session->http->sendHeader; - last; + return; } } } - - $session->close; - return $session->response->finalize; + return; } no Moose; diff --git a/lib/WebGUI/Request.pm b/lib/WebGUI/Request.pm index 873462102..0d3c9bc06 100644 --- a/lib/WebGUI/Request.pm +++ b/lib/WebGUI/Request.pm @@ -6,7 +6,9 @@ The WebGUI server response object. See L =cut +use strict; use parent qw(Plack::Request); +use Plack::Util::Accessor qw(session); use WebGUI::Response; =head1 METHODS @@ -23,7 +25,9 @@ See L sub new_response { my $self = shift; - WebGUI::Response->new(@_); + my $response = WebGUI::Response->new(@_); + $response->session($self->session); + return $response; } 1; \ No newline at end of file diff --git a/lib/WebGUI/Response.pm b/lib/WebGUI/Response.pm index dbd3a29dc..6c0e15fc9 100644 --- a/lib/WebGUI/Response.pm +++ b/lib/WebGUI/Response.pm @@ -2,7 +2,7 @@ package WebGUI::Response; use strict; use parent qw(Plack::Response); -use Plack::Util::Accessor qw(streaming writer streamer); +use Plack::Util::Accessor qw(session streaming writer streamer); =head2 DESCRIPTION @@ -12,9 +12,8 @@ The WebGUI server response object. See of L sub stream { my $self = shift; - my $streamer = shift; + $self->streamer(shift); $self->streaming(1); - $self->streamer($streamer); } sub stream_write { diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 43dc23601..a012560c0 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -458,8 +458,11 @@ sub open { my $config = ref $c ? $c : WebGUI::Config->new($webguiRoot,$c); my $self = {_config=>$config }; # TODO - if we store reference here, should we weaken WebGUI->config? bless $self , $class; - $self->{_request} = $request if defined $request; - $self->{_response} = $request->new_response( 200 ) if defined $request; + if (defined $request) { + $request->session($self); # hello circular reference + $self->{_request} = $request; + $self->{_response} = $request->new_response( 200 ); + } my $sessionId = shift || $request->cookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Output.pm b/lib/WebGUI/Session/Output.pm index 82e31d09e..c148dc62c 100644 --- a/lib/WebGUI/Session/Output.pm +++ b/lib/WebGUI/Session/Output.pm @@ -95,10 +95,14 @@ sub print { print $handle $content; } elsif ($self->session->response) { - if ($self->session->response->streaming) { - $self->session->response->stream_write($content); + 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 { From 1ad2f0cfd7e190c2ac92603c5d818b7569d7cc69 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Wed, 7 Apr 2010 10:50:45 -0400 Subject: [PATCH 31/92] minor refactoring --- README | 2 +- TODO | 4 +- eg/basic.psgi => app.psgi | 0 apache.conf => eg/apache.conf | 0 {etc => eg}/dev.localhost.localdomain.cgi | 0 {etc => eg}/dev.localhost.localdomain.fcgi | 0 {etc => eg}/dev.localhost.localdomain.perlbal | 0 lib/WebGUI.pm | 2 +- lib/WebGUI/Session/Request.pm | 40 ------------------- 9 files changed, 4 insertions(+), 44 deletions(-) rename eg/basic.psgi => app.psgi (100%) rename apache.conf => eg/apache.conf (100%) rename {etc => eg}/dev.localhost.localdomain.cgi (100%) rename {etc => eg}/dev.localhost.localdomain.fcgi (100%) rename {etc => eg}/dev.localhost.localdomain.perlbal (100%) delete mode 100644 lib/WebGUI/Session/Request.pm diff --git a/README b/README index f37e9ba14..14daa6d51 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ This is the PSGI branch of WebGUI8 Currently, the best performance is achieved via: - plackup eg/basic.psgi -E none -s Starman --workers 10 + plackup -E none -s Starman --workers 10 You can benchmark your server via: diff --git a/TODO b/TODO index 3ee21a684..4981c66fe 100644 --- a/TODO +++ b/TODO @@ -1,10 +1,10 @@ TODO * Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response * Turn logger into $self->request->env->{'psgi.errors'}->print(join '', @stuff); -* Remove WebGUI::Session::Output 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 \ No newline at end of file +* urlHandler API changed - no longer gets server, config +* Streaming response body \ No newline at end of file diff --git a/eg/basic.psgi b/app.psgi similarity index 100% rename from eg/basic.psgi rename to app.psgi diff --git a/apache.conf b/eg/apache.conf similarity index 100% rename from apache.conf rename to eg/apache.conf diff --git a/etc/dev.localhost.localdomain.cgi b/eg/dev.localhost.localdomain.cgi similarity index 100% rename from etc/dev.localhost.localdomain.cgi rename to eg/dev.localhost.localdomain.cgi diff --git a/etc/dev.localhost.localdomain.fcgi b/eg/dev.localhost.localdomain.fcgi similarity index 100% rename from etc/dev.localhost.localdomain.fcgi rename to eg/dev.localhost.localdomain.fcgi diff --git a/etc/dev.localhost.localdomain.perlbal b/eg/dev.localhost.localdomain.perlbal similarity index 100% rename from etc/dev.localhost.localdomain.perlbal rename to eg/dev.localhost.localdomain.perlbal diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index fe116d57b..344f88aa0 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -224,7 +224,7 @@ sub handle { # "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"; + warn "chunked and empty no longer stream, use session->response->stream() instead"; if ($session->errorHandler->canShowDebug()) { $session->output->print($session->errorHandler->showDebug(),1); } diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm deleted file mode 100644 index 3c1cc87a3..000000000 --- a/lib/WebGUI/Session/Request.pm +++ /dev/null @@ -1,40 +0,0 @@ -package WebGUI::Session::Request; - -use strict; -use warnings; - -=head1 DESCRIPTION - -This class wraps calls to $session->request and logs them as a cute way of seeing -what Apache2::* methods webgui is calling - -=cut - -sub new { - my $class = shift; - bless { @_ }, $class; -} - -our $AUTOLOAD; -sub AUTOLOAD { - my $self = shift; - my $what = $AUTOLOAD; - $what =~ s/.*:://; - my $r = $self->{r}; - my $session = $self->{session}; - - if ( !$r ) { - $session->log->error("!!request->$what(@_) but r not defined"); - return; - } - - if ( $what eq 'print' ) { - $session->log->error("!!request->$what(print--chomped)"); - } - else { - $session->log->error("!!request->$what(@_)"); - } - return $r->$what(@_); -} - -1; From b7e7d5b936c9be0e3ffb51a10f1ec26727863689 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Thu, 8 Apr 2010 21:30:55 -0400 Subject: [PATCH 32/92] Refactored Request/Response into WebGUI::Session:: --- lib/WebGUI.pm | 82 ++++++++++++++-------------- lib/WebGUI/Request.pm | 33 ----------- lib/WebGUI/Session.pm | 38 ++++++++----- lib/WebGUI/Session/Request.pm | 40 ++++++++++++++ lib/WebGUI/{ => Session}/Response.pm | 14 ++++- 5 files changed, 117 insertions(+), 90 deletions(-) delete mode 100644 lib/WebGUI/Request.pm create mode 100644 lib/WebGUI/Session/Request.pm rename lib/WebGUI/{ => Session}/Response.pm (56%) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 344f88aa0..c8697e678 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -25,7 +25,7 @@ use WebGUI::Config; use WebGUI::Pluggable; use WebGUI::Session; use WebGUI::User; -use WebGUI::Request; +use WebGUI::Session::Request; use Moose; use Try::Tiny; @@ -81,53 +81,51 @@ sub psgi_app { return $self->{psgi_app} ||= $self->compile_psgi_app; } -sub new_session { - my $self = shift; - my $request = shift; - - # determine session id - my $sessionId = $request->cookies->{$self->config->getCookieName}; - - # Instantiate the session object - return WebGUI::Session->open($self->root, $self->config, $request, $sessionId); -} - sub compile_psgi_app { my $self = shift; my $catch = [ 500, [ 'Content-Type' => 'text/plain' ], [ "Internal Server Error\n" ] ]; + # WebGUI is a PSGI app is a Perl code reference. Let's create one. + # Each web request results in a call to this sub my $app = sub { my $env = shift; - my $log = sub { - $env->{'psgi.errors'}->print(join '', @_, "\n"); - }; - + # 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 $callback = shift; - my $request = WebGUI::Request->new($env); - my $session = $self->new_session($request); + my $responder = shift; - try { - $self->handle($request); - } catch { - $log->( "Error handling request: $_" ); - $callback->( $catch ); - return; - }; + # Open the WebGUI Session + # my $session = WebGUI::Session->open($self->root, $self->config, $env, $env->{'psgix.session'}->id); + my $session = WebGUI::Session->open($self->root, $self->config, $env); + # Handle the request + $self->handle($session); + + # Uncomment to catch errors (currently I prefer letting StackTrace do its thing) + # try { + # $self->handle($session); + # } catch { + # $session->request->log( "Error handling request: $_" ); + # $responder->( $catch ); + # return; + # }; + + # Construct the PSGI response my $response = $session->response; my $psgi_response = $response->finalize; + # See if the content handler is doing unbuffered response writing if ( $response->streaming ) { try { - # Ask PSGI server for a streaming writer object by returning a 2-part - # arrayref instead of a 3-part array - my $writer = $callback->( [ $psgi_response->[0], $psgi_response->[1] ] ); + # 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] ] ); - # Store the writer object in the WebGUI::Response object + # Store the writer object in the WebGUI::Session::Response object $response->writer($writer); # Now call the callback that does the streaming @@ -139,13 +137,15 @@ sub compile_psgi_app { } catch { if ($response->writer) { # Response has already been started, so log error and close writer - $log->("Error detected after streaming response started"); + $session->request->TRACE("Error detected after streaming response started"); $response->writer->close; } else { - $callback->( $catch ); + $responder->( $catch ); } + } finally { $session->close; + }; } else { @@ -153,7 +153,7 @@ sub compile_psgi_app { # the response. In the future we could use an Event framework here # to make this a non-blocking delayed response. $session->close; - $callback->($psgi_response); + $responder->($psgi_response); } } }; @@ -176,18 +176,20 @@ sub compile_psgi_app { path => sub { s{^$uploadsURL/}{} }, root => "$uploadsPath/", ); + + # Session - TODO: make this user configurable + # use Plack::Middleware::Session; + # $app = Plack::Middleware::Session->wrap($app); return $app; } sub handle { - my ( $self, $request ) = @_; - - my $session = $request->session; + 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; + # $session->output->print("WebGUI PSGI with contentHandlers short-circuited for benchmarking\n"); + # return; # contentHandlers that return text will have that content returned as the response # Alternatively, contentHandlers can stream the response body by calling: @@ -203,7 +205,7 @@ sub handle { # sleep 1; # $session->output->print("...see?\n"); # }); -# return; +# return; # TODO: refactor the following loop, find all instances of "chunked" and "empty" in codebase, etc.. for my $handler (@{$self->config->get("contentHandlers")}) { @@ -224,7 +226,7 @@ sub handle { # "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"; + #warn "chunked and empty no longer stream, use session->response->stream() instead"; if ($session->errorHandler->canShowDebug()) { $session->output->print($session->errorHandler->showDebug(),1); } diff --git a/lib/WebGUI/Request.pm b/lib/WebGUI/Request.pm deleted file mode 100644 index 0d3c9bc06..000000000 --- a/lib/WebGUI/Request.pm +++ /dev/null @@ -1,33 +0,0 @@ -package WebGUI::Request; - -=head2 DESCRIPTION - -The WebGUI server response object. See L - -=cut - -use strict; -use parent qw(Plack::Request); -use Plack::Util::Accessor qw(session); -use WebGUI::Response; - -=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; - my $response = WebGUI::Response->new(@_); - $response->session($self->session); - return $response; -} - -1; \ No newline at end of file diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index a012560c0..d60538350 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -29,6 +29,7 @@ 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; @@ -424,7 +425,7 @@ sub log { #------------------------------------------------------------------- -=head2 open ( webguiRoot, configFile [, requestObject, sessionId, noFuss ] ) +=head2 open ( webguiRoot, configFile [, env, sessionId, noFuss ] ) Constructor. Opens a closed ( or new ) WebGUI session. @@ -436,13 +437,14 @@ The path to the WebGUI files. The filename of the config file that WebGUI should operate from, or a WebGUI::Config object -=head3 requestObject +=head3 env -The Plack::Request object. 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 @@ -451,21 +453,29 @@ Uses simple session vars. See WebGUI::Session::Var::new() for more details. =cut sub open { - my $class = shift; - my $webguiRoot = shift; - my $c = shift; - my $request = shift; + my ($class, $webguiRoot, $c, $env, $sessionId, $noFuss) = @_; my $config = ref $c ? $c : WebGUI::Config->new($webguiRoot,$c); my $self = {_config=>$config }; # TODO - if we store reference here, should we weaken WebGUI->config? - bless $self , $class; - if (defined $request) { - $request->session($self); # hello circular reference - $self->{_request} = $request; + bless $self, $class; + + if ($env) { + my $request = WebGUI::Session::Request->new($env); + $self->{_request} = $request; $self->{_response} = $request->new_response( 200 ); + + # TODO: it might be nice to set a default Content-type here, but we can't until Assets can override it again + # $self->{_response} = $request->new_response( 200 );#, [ 'Content-type' => 'text/html; charset=UTF-8' ] ); + + # Use the WebGUI::Session::Request object to look up the sessionId from cookies, if it + # wasn't given explicitly + $sessionId ||= $request->cookies->{$config->getCookieName}; } - my $sessionId = shift || $request->cookies->{$config->getCookieName} || $self->id->generate; - $sessionId = $self->id->generate unless $self->id->valid($sessionId); - my $noFuss = shift; + + # If the sessionId is still unset or is invalid, generate a new one + if (!$sessionId || !$self->id->valid($sessionId)) { + $sessionId = $self->id->generate; + } + $self->{_var} = WebGUI::Session::Var->new($self,$sessionId, $noFuss); 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/Response.pm b/lib/WebGUI/Session/Response.pm similarity index 56% rename from lib/WebGUI/Response.pm rename to lib/WebGUI/Session/Response.pm index 6c0e15fc9..f94b196e9 100644 --- a/lib/WebGUI/Response.pm +++ b/lib/WebGUI/Session/Response.pm @@ -1,12 +1,20 @@ -package WebGUI::Response; +package WebGUI::Session::Response; use strict; use parent qw(Plack::Response); use Plack::Util::Accessor qw(session streaming writer streamer); -=head2 DESCRIPTION +=head1 SYNOPSIS -The WebGUI server response object. See of L + 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 From 10e8d1898d03ec99f1c7bd456b79334c361e799d Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Apr 2010 01:12:30 -0400 Subject: [PATCH 33/92] More refactoring and documentation improvements --- README | 15 ++++++++- TODO | 6 +++- app.psgi | 24 +++++++++----- benchmark.pl | 7 ++-- eg/README | 23 +++++++++++++ lib/WebGUI.pm | 56 ++++++++++++++------------------ lib/WebGUI/Middleware/Session.pm | 50 ++++++++++++++++++++++++++++ lib/WebGUI/Session.pm | 6 ++-- 8 files changed, 140 insertions(+), 47 deletions(-) create mode 100644 eg/README create mode 100644 lib/WebGUI/Middleware/Session.pm diff --git a/README b/README index 14daa6d51..1854a0459 100644 --- a/README +++ b/README @@ -8,4 +8,17 @@ You can benchmark your server via: ab -t 3 -c 10 -k http://dev.localhost.localdomain:5000/ | grep Req -I'm currently getting 20 requests/second, whereas I'm getting 30/second on the non-PSGI WebGUI8 branch. \ No newline at end of file +I'm currently getting 23 requests/second, whereas I'm getting 30/second on the non-PSGI WebGUI8 branch. + += ARCHITECTURE = + +* The .psgi file gets to set WEBGUI_ROOT and WEBGUI_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) + \ No newline at end of file diff --git a/TODO b/TODO index 4981c66fe..de30c8e4d 100644 --- a/TODO +++ b/TODO @@ -7,4 +7,8 @@ DONE * serverObject gone from WebGUI::Session::open() * WebGUI::authen API changed * urlHandler API changed - no longer gets server, config -* Streaming response body \ No newline at end of file +* Streaming response body + +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/app.psgi b/app.psgi index 6306850cc..e36b92f3b 100644 --- a/app.psgi +++ b/app.psgi @@ -1,12 +1,18 @@ +use strict; +use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; -# 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; -# Or equivalently (using the defaults): -WebGUI->new; \ No newline at end of file +my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' ); + +builder { + + # Open/close the WebGUI::Session at the outer-most onion layer + enable '+WebGUI::Middleware::Session', config => $wg->config; + + # Any additional WebGUI Middleware goes here + # .. + + # Return the app + $wg; +}; diff --git a/benchmark.pl b/benchmark.pl index 329a95c7b..e269ba619 100755 --- a/benchmark.pl +++ b/benchmark.pl @@ -1,14 +1,17 @@ # Little script used to run benchmarks against dev.localhost.localdomain # # To profile, run "perl -d:NYTProf benchmark.pl" +use Devel::Leak::Object qw(GLOBAL_bless); +$Devel::Leak::Object::TRACKSOURCELINES = 1; use lib '/data/WebGUI/lib'; use WebGUI; use Plack::Test; use HTTP::Request::Common; -my $app = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' )->psgi_app; +my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' ); +my $app = $wg->psgi_app; test_psgi $app, sub { my $cb = shift; my $res = $cb->( GET "/" ); -} for 1..100; +} for 1..100; \ 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/lib/WebGUI.pm b/lib/WebGUI.pm index c8697e678..445643c70 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -29,12 +29,6 @@ use WebGUI::Session::Request; use Moose; use Try::Tiny; -has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); -has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); -has config => ( is => 'rw', isa => 'WebGUI::Config' ); - -use overload q(&{}) => sub { shift->psgi_app }, fallback => 1; - =head1 NAME Package WebGUI @@ -53,6 +47,10 @@ These subroutines are available from this package: =cut +has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); +has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); +has config => ( is => 'rw', isa => 'WebGUI::Config' ); + around BUILDARGS => sub { my $orig = shift; my $class = shift; @@ -74,7 +72,9 @@ sub BUILD { # Instantiate the WebGUI::Config object my $config = WebGUI::Config->new( $self->root, $self->site ); $self->config($config); -} +} + +use overload q(&{}) => sub { shift->psgi_app }, fallback => 1; sub psgi_app { my $self = shift; @@ -84,7 +84,7 @@ sub psgi_app { sub compile_psgi_app { my $self = shift; - my $catch = [ 500, [ 'Content-Type' => 'text/plain' ], [ "Internal Server Error\n" ] ]; + my $catch = [ 500, [ 'Content-Type' => 'text/plain' ], [ "Internal Server Error" ] ]; # WebGUI is a PSGI app is a Perl code reference. Let's create one. # Each web request results in a call to this sub @@ -96,10 +96,7 @@ sub compile_psgi_app { # unbuffered response writing return sub { my $responder = shift; - - # Open the WebGUI Session - # my $session = WebGUI::Session->open($self->root, $self->config, $env, $env->{'psgix.session'}->id); - my $session = WebGUI::Session->open($self->root, $self->config, $env); + my $session = $env->{'webgui.session'} or die 'Missing WebGUI Session - check WebGUI::Middleware::Session'; # Handle the request $self->handle($session); @@ -143,21 +140,22 @@ sub compile_psgi_app { $responder->( $catch ); } - } finally { - $session->close; - - }; + } } 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. - $session->close; $responder->($psgi_response); } } }; + # Wrap $app with some extra middleware that acts as a fallback for when + # you're not using something fast to serve static content + # + # This could also be in the .psgi file, but it seems sensible to have it + # baked in as a fallback (unless we find it drains performance) my $config = $self->config; # Extras @@ -176,12 +174,6 @@ sub compile_psgi_app { path => sub { s{^$uploadsURL/}{} }, root => "$uploadsPath/", ); - - # Session - TODO: make this user configurable - # use Plack::Middleware::Session; - # $app = Plack::Middleware::Session->wrap($app); - - return $app; } sub handle { @@ -199,16 +191,18 @@ sub handle { # This is generally a good thing to do, unless you want to send a file. # 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; + # $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 (@{$self->config->get("contentHandlers")}) { + 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); diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm new file mode 100644 index 000000000..ce48b38e7 --- /dev/null +++ b/lib/WebGUI/Middleware/Session.pm @@ -0,0 +1,50 @@ +package WebGUI::Middleware::Session; +use strict; +use parent qw(Plack::Middleware); +use WebGUI::Config; +use WebGUI::Session; + +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. + +=cut + +sub call { + my ( $self, $env ) = @_; + + my $config = $self->config or die 'Mandatory config parameter missing'; + + # Open the Session + $env->{'webgui.session'} = WebGUI::Session->open( $config->getWebguiRoot, $config, $env ); + + # Run the app + my $res = $self->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'}; + } + ); +} + +1; diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index d60538350..e27423320 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -145,7 +145,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 _os _privilege _scratch _setting _stow _style _url _user _var _cache _errorHandler _response _request/) { delete $self->{$key}; } } @@ -463,8 +463,8 @@ sub open { $self->{_request} = $request; $self->{_response} = $request->new_response( 200 ); - # TODO: it might be nice to set a default Content-type here, but we can't until Assets can override it again - # $self->{_response} = $request->new_response( 200 );#, [ 'Content-type' => 'text/html; charset=UTF-8' ] ); + # TODO: it might be nice to set a default Content-Type here, but we can't until Assets can override it again + # $self->{_response} = $request->new_response( 200 );#, [ 'Content-Type' => 'text/html; charset=UTF-8' ] ); # Use the WebGUI::Session::Request object to look up the sessionId from cookies, if it # wasn't given explicitly From f22020c2677900385bb5c2219dc8bb402dd5af34 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Apr 2010 18:06:43 -0400 Subject: [PATCH 34/92] Turned on Debug middleware Removed unnecessary $session->close() now that we have WebGUI::Middleware::Session Fixed Content-Type bug --- TODO | 1 + app.psgi | 1 + lib/WebGUI.pm | 9 --------- lib/WebGUI/Content/Asset.pm | 2 -- lib/WebGUI/Session.pm | 3 --- lib/WebGUI/Session/ErrorHandler.pm | 5 ++--- lib/WebGUI/Session/Http.pm | 4 ++-- 7 files changed, 6 insertions(+), 19 deletions(-) diff --git a/TODO b/TODO index de30c8e4d..b4ccc4950 100644 --- a/TODO +++ b/TODO @@ -8,6 +8,7 @@ DONE * WebGUI::authen API changed * urlHandler API changed - no longer gets server, config * Streaming response body +* Delete lib/WebGUI/URL and replace with new Middleware(s) NB * Periodically do a big stress-test and check for leaks, mysql overload etc.. diff --git a/app.psgi b/app.psgi index e36b92f3b..4fbe77830 100644 --- a/app.psgi +++ b/app.psgi @@ -6,6 +6,7 @@ use WebGUI; my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' ); builder { + enable 'Debug', panels => [ qw(Environment Response Timer Memory Session DBITrace PerlConfig Response) ]; # Open/close the WebGUI::Session at the outer-most onion layer enable '+WebGUI::Middleware::Session', config => $wg->config; diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 445643c70..178fb61d2 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -101,15 +101,6 @@ sub compile_psgi_app { # Handle the request $self->handle($session); - # Uncomment to catch errors (currently I prefer letting StackTrace do its thing) - # try { - # $self->handle($session); - # } catch { - # $session->request->log( "Error handling request: $_" ); - # $responder->( $catch ); - # return; - # }; - # Construct the PSGI response my $response = $session->response; my $psgi_response = $response->finalize; diff --git a/lib/WebGUI/Content/Asset.pm b/lib/WebGUI/Content/Asset.pm index 6ea455947..bbbae724d 100644 --- a/lib/WebGUI/Content/Asset.pm +++ b/lib/WebGUI/Content/Asset.pm @@ -113,7 +113,6 @@ sub handler { if ($var->get("userId") eq "1" && defined $asset && !$http->ifModifiedSince($asset->getContentLastModified)) { $http->setStatus("304","Content Not Modified"); $http->sendHeader; - $session->close; return "chunked"; } @@ -128,7 +127,6 @@ sub handler { my $ct = guess_media_type($filename); my $oldContentType = $request->content_type($ct); if ($request->sendfile($filename) ) { - $session->close; return; # TODO - what should we return to indicate streaming? } else { diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index e27423320..030e88f72 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -463,9 +463,6 @@ sub open { $self->{_request} = $request; $self->{_response} = $request->new_response( 200 ); - # TODO: it might be nice to set a default Content-Type here, but we can't until Assets can override it again - # $self->{_response} = $request->new_response( 200 );#, [ 'Content-Type' => 'text/html; charset=UTF-8' ] ); - # Use the WebGUI::Session::Request object to look up the sessionId from cookies, if it # wasn't given explicitly $sessionId ||= $request->cookies->{$config->getCookieName}; diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 917fb6ebe..fcddcd73d 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -223,11 +223,10 @@ sub fatal { 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->session->response->content_type('text/html') if ($self->session->response); $self->getLogger->fatal($message); $self->getLogger->debug("Stack trace for FATAL ".$message."\n".$self->getStackTrace()); - $self->session->http->sendHeader if ($self->session->request); + $self->session->http->sendHeader if ($self->session->response); if (! defined $self->session->db(1)) { # We can't even _determine_ whether we can show the debug text. Punt. diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 313486fc8..67e753e04 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -279,13 +279,13 @@ sub sendHeader { $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; # under these circumstances, don't allow caching if ($userId ne "1" || $cacheControl eq "none" || $self->session->setting->get("preventProxyCache")) { $response->header("Cache-Control" => "private, max-age=1"); -# $request->no_cache(1); # TODO - re-enable this? +# $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 { From 2bac95fa268908020de284d170ecfe29bfa622f8 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Apr 2010 18:44:12 -0400 Subject: [PATCH 35/92] Mostly decoupled WebGUI from Log4perl --- TODO | 2 +- app.psgi | 1 + lib/WebGUI/Session/ErrorHandler.pm | 39 ++++++++++++++---------------- 3 files changed, 20 insertions(+), 22 deletions(-) diff --git a/TODO b/TODO index b4ccc4950..b890d2ab5 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,5 @@ TODO * Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response -* Turn logger into $self->request->env->{'psgi.errors'}->print(join '', @stuff); DONE * $session->request is now a Plack::Request object @@ -9,6 +8,7 @@ DONE * urlHandler API changed - no longer gets server, config * Streaming response body * Delete lib/WebGUI/URL and replace with new Middleware(s) +* Mostly decoupled WebGUI from Log4perl NB * Periodically do a big stress-test and check for leaks, mysql overload etc.. diff --git a/app.psgi b/app.psgi index 4fbe77830..0bc5e18c0 100644 --- a/app.psgi +++ b/app.psgi @@ -7,6 +7,7 @@ my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain builder { enable 'Debug', panels => [ qw(Environment Response Timer Memory Session DBITrace PerlConfig Response) ]; + enable 'Log4perl', category => 'mysite', conf => $wg->config->getWebguiRoot . '/etc/log.conf'; # Open/close the WebGUI::Session at the outer-most onion layer enable '+WebGUI::Middleware::Session', config => $wg->config; diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index fcddcd73d..abb6d3c08 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -16,10 +16,9 @@ package WebGUI::Session::ErrorHandler; use strict; -use Log::Log4perl; -#use Apache2::RequestUtil; use JSON; use HTML::Entities qw(encode_entities); +use Log::Log4perl; =head1 NAME @@ -162,8 +161,8 @@ The message you wish to add to the log. sub debug { my $self = shift; my $message = shift; - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; - $self->getLogger->debug($message); + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; + $self->getLogger->({ level => 'debug', message => $message }); $self->{_debug_debug} .= $message."\n"; } @@ -198,9 +197,9 @@ The message you wish to add to the log. 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()); + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; + $self->getLogger->({ level => 'error', message => $message}); + $self->getLogger->({ level => 'debug', message => "Stack trace for ERROR ".$message."\n".$self->getStackTrace() }); $self->{_debug_error} .= $message."\n"; } @@ -221,11 +220,11 @@ sub fatal { my $self = shift; my $message = shift; - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; $self->session->http->setStatus("500","Server Error"); $self->session->response->content_type('text/html') if ($self->session->response); - $self->getLogger->fatal($message); - $self->getLogger->debug("Stack trace for FATAL ".$message."\n".$self->getStackTrace()); + $self->getLogger->({ level => 'fatal', message => $message }); + $self->getLogger->({ level => 'debug', message => "Stack trace for FATAL ".$message."\n".$self->getStackTrace() }); $self->session->http->sendHeader if ($self->session->response); if (! defined $self->session->db(1)) { @@ -262,7 +261,7 @@ Returns a reference to the logger. sub getLogger { my $self = shift; - return $self->{_logger}; + return $self->session->request->logger; } @@ -302,8 +301,8 @@ The message you wish to add to the log. sub info { my $self = shift; my $message = shift; - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; - $self->getLogger->info($message); + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; + $self->getLogger->({ level => 'info', message => $message }); $self->{_debug_info} .= $message."\n"; } @@ -322,9 +321,7 @@ An active WebGUI::Session object. sub new { my $class = shift; my $session = shift; - Log::Log4perl->init_once( $session->config->getWebguiRoot."/etc/log.conf" ); - my $logger = Log::Log4perl->get_logger($session->config->getFilename); - bless {_queryCount=>0, _logger=>$logger, _session=>$session}, $class; + bless {_queryCount=>0, _session=>$session}, $class; } #---------------------------------------------------------------------------- @@ -357,7 +354,7 @@ A sql statement string. sub query { my $self = shift; - return unless $self->canShowDebug || $self->getLogger->is_debug; + return unless $self->canShowDebug; # TODO - re-enable || $self->getLogger->is_debug; my $query = shift; my $placeholders = shift; $self->{_queryCount}++; @@ -378,8 +375,8 @@ sub query { $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"); + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $depth + 2; + $self->getLogger->({ level => 'debug', message => "query $self->{_queryCount}:\n$query$plac" }); } @@ -470,8 +467,8 @@ The message you wish to add to the log. sub warn { my $self = shift; my $message = shift; - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; - $self->getLogger->warn($message); + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; + $self->getLogger->({ level => 'warn', message => $message }); $self->{_debug_warn} .= $message."\n"; } From 716bdaeb8617ca9dde37b918eb98928020637aff Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Apr 2010 22:52:40 -0400 Subject: [PATCH 36/92] Added exception handling Added error doc mapping Moved more logic into Session middleware Added Credit example to app.psgi Made StackTrace and Debug panel automatically turn on when debug mode enabled Fixed errorHandler --- TODO | 5 +- app.psgi | 15 ++-- lib/WebGUI.pm | 2 +- lib/WebGUI/Middleware/Debug.pm | 39 ++++++++++ lib/WebGUI/Middleware/Session.pm | 39 +++++++++- lib/WebGUI/Session/ErrorHandler.pm | 43 +++++++---- lib/WebGUI/URL/Content.pm | 116 ----------------------------- 7 files changed, 114 insertions(+), 145 deletions(-) create mode 100644 lib/WebGUI/Middleware/Debug.pm delete mode 100644 lib/WebGUI/URL/Content.pm diff --git a/TODO b/TODO index b890d2ab5..70fd1f4e2 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,8 @@ TODO * Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response +* Delete lib/WebGUI/URL and replace with new Middleware(s) +* Investigate moving Cookie handling into middleware +* Turn html debug output into a Plack::Middleware::Debug panel DONE * $session->request is now a Plack::Request object @@ -7,8 +10,8 @@ DONE * WebGUI::authen API changed * urlHandler API changed - no longer gets server, config * Streaming response body -* Delete lib/WebGUI/URL and replace with new Middleware(s) * Mostly decoupled WebGUI from Log4perl +* Exception handling and error doc mapping NB * Periodically do a big stress-test and check for leaks, mysql overload etc.. diff --git a/app.psgi b/app.psgi index 0bc5e18c0..ffc1d3c83 100644 --- a/app.psgi +++ b/app.psgi @@ -3,17 +3,18 @@ use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; -my $wg = WebGUI->new( root => '/data/WebGUI', site => 'dev.localhost.localdomain.conf' ); +my $root = '/data/WebGUI'; +my $wg = WebGUI->new( root => $root, site => 'dev.localhost.localdomain.conf' ); builder { - enable 'Debug', panels => [ qw(Environment Response Timer Memory Session DBITrace PerlConfig Response) ]; - enable 'Log4perl', category => 'mysite', conf => $wg->config->getWebguiRoot . '/etc/log.conf'; + + enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; + enable 'Static', root => $root, path => sub { s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt} }; # Open/close the WebGUI::Session at the outer-most onion layer - enable '+WebGUI::Middleware::Session', config => $wg->config; - - # Any additional WebGUI Middleware goes here - # .. + enable '+WebGUI::Middleware::Session', + config => $wg->config;#, + #error_docs => { 500 => "$root/www/maintenance.html" }; # Return the app $wg; diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 178fb61d2..33733f932 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -220,7 +220,7 @@ sub handle { # non-empty output should be used as the response body elsif (defined $output && $output ne "") { # Auto-set the headers - $session->http->sendHeader; # TODO: should be renamed setHeader + $session->http->sendHeader; # Use contentHandler's return value as the output $session->output->print($output); diff --git a/lib/WebGUI/Middleware/Debug.pm b/lib/WebGUI/Middleware/Debug.pm new file mode 100644 index 000000000..6098687bc --- /dev/null +++ b/lib/WebGUI/Middleware/Debug.pm @@ -0,0 +1,39 @@ +package WebGUI::Middleware::Debug; +use strict; +use parent qw(Plack::Middleware); +use Plack::Middleware::StackTrace; +use Plack::Middleware::Debug; +use Plack::Middleware::HttpExceptions; + +=head1 NAME + +WebGUI::Middleware::Debug - + +=head1 DESCRIPTION + +This is PSGI middleware for WebGUI that + +=cut + +sub call { + my ( $self, $env ) = @_; + + my $session = $env->{'webgui.session'} or die 'WebGUI::Session missing'; + + my $app = $self->app; + + if ( $session->log->canShowDebug ) { + warn 'seeing webgui.debug'; + $env->{'webgui.debug'} = 1; + $app = Plack::Middleware::StackTrace->wrap($app); + $app = Plack::Middleware::Debug->wrap( $app, + panels => [qw(Environment Response Timer Memory Session DBITrace PerlConfig Response)] ); + } + + # Turn exceptions into HTTP errors + $app = Plack::Middleware::HTTPExceptions->wrap( $app ); + + return $app->($env); +} + +1; diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index ce48b38e7..069bc3506 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -3,8 +3,13 @@ use strict; use parent qw(Plack::Middleware); use WebGUI::Config; use WebGUI::Session; +use Try::Tiny; +use Plack::Middleware::StackTrace; +use Plack::Middleware::Debug; +use Plack::Middleware::HTTPExceptions; +use Plack::Middleware::ErrorDocument; -use Plack::Util::Accessor qw( config ); +use Plack::Util::Accessor qw( config error_docs ); =head1 NAME @@ -26,13 +31,39 @@ and not worry about closing it. sub call { my ( $self, $env ) = @_; + my $app = $self->app; my $config = $self->config or die 'Mandatory config parameter missing'; - # Open the Session - $env->{'webgui.session'} = WebGUI::Session->open( $config->getWebguiRoot, $config, $env ); + my $session = try { + $env->{'webgui.session'} = WebGUI::Session->open( $config->getWebguiRoot, $config, $env ); + }; + + 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 + # (using the error_docs mapping) + return Plack::Middleware::ErrorDocument->wrap( + sub { [ 500, [], [] ] }, + %{ $self->error_docs } )->($env); + } + + my $debug = $session->log->canShowDebug; + if ($debug) { + $app = Plack::Middleware::StackTrace->wrap($app); + $app = Plack::Middleware::Debug->wrap( $app, + panels => [qw(Environment Response Timer Memory Session DBITrace PerlConfig Response)] ); + } + + # Turn exceptions into HTTP errors + $app = Plack::Middleware::HTTPExceptions->wrap($app); + + # HTTP error document mapping + if ( !$debug && $self->error_docs ) { + $app = Plack::Middleware::ErrorDocument->wrap( $app, %{ $self->error_docs } ); + } # Run the app - my $res = $self->app->($env); + my $res = $app->($env); # Use callback style response return $self->response_cb( diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index abb6d3c08..783247567 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -19,6 +19,7 @@ use strict; use JSON; use HTML::Entities qw(encode_entities); use Log::Log4perl; +use WebGUI::Exception; =head1 NAME @@ -221,33 +222,43 @@ sub fatal { my $message = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; - $self->session->http->setStatus("500","Server Error"); - $self->session->response->content_type('text/html') if ($self->session->response); $self->getLogger->({ level => 'fatal', message => $message }); $self->getLogger->({ level => 'debug', message => "Stack trace for FATAL ".$message."\n".$self->getStackTrace() }); - $self->session->http->sendHeader if ($self->session->response); + my $error; 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

"); + $error = q{

Fatal Internal Error

}; } 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); + my $stack = encode_entities($self->getStackTrace); + my $debug = $self->showDebug(); + $error = <WebGUI Fatal Error +

Something unexpected happened that caused this system to fault.

+

$message

+
$stack
+$debug +END_HTML } 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); + my $company = $self->session->setting->get("companyName"); + my $email = $self->session->setting->get("companyEmail"); + my $url = $self->session->setting->get("companyURL"); + + $error = <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.
+
$company +
$email +
$url +END_HTML } - $self->session->close(); - last WEBGUI_FATAL; + + # Fatal errors cause an exception to be thrown + WebGUI::Error->throw( error => $error ); } diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm deleted file mode 100644 index 14a2d8fd4..000000000 --- a/lib/WebGUI/URL/Content.pm +++ /dev/null @@ -1,116 +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'); - unless (defined $session) { - $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); - } - WEBGUI_FATAL: 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; - 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; - From 42c1a8e1492893e97aa6c30e5512a5802d8bfff8 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Apr 2010 23:40:14 -0400 Subject: [PATCH 37/92] Made $session->log->fatal() message pass through --- app.psgi | 4 +-- lib/WebGUI/Exception.pm | 6 ++++ lib/WebGUI/Middleware/Debug.pm | 39 ------------------------- lib/WebGUI/Middleware/HTTPExceptions.pm | 36 +++++++++++++++++++++++ lib/WebGUI/Middleware/Session.pm | 15 +++++----- lib/WebGUI/Session/ErrorHandler.pm | 6 ++-- 6 files changed, 55 insertions(+), 51 deletions(-) delete mode 100644 lib/WebGUI/Middleware/Debug.pm create mode 100644 lib/WebGUI/Middleware/HTTPExceptions.pm diff --git a/app.psgi b/app.psgi index ffc1d3c83..d42c34d7a 100644 --- a/app.psgi +++ b/app.psgi @@ -13,8 +13,8 @@ builder { # Open/close the WebGUI::Session at the outer-most onion layer enable '+WebGUI::Middleware::Session', - config => $wg->config;#, - #error_docs => { 500 => "$root/www/maintenance.html" }; + config => $wg->config, + error_docs => { 500 => "$root/www/maintenance.html" }; # Return the app $wg; diff --git a/lib/WebGUI/Exception.pm b/lib/WebGUI/Exception.pm index 2e28b1231..cb9755d62 100644 --- a/lib/WebGUI/Exception.pm +++ b/lib/WebGUI/Exception.pm @@ -264,6 +264,12 @@ use Exception::Class ( description => "Couldn't establish a connection.", fields => [qw{ resource }], }, + + + 'WebGUI::Error::Fatal' => { + isa => 'WebGUI::Error', + description => "Fatal error that should be shown to all site visitors.", + }, ); diff --git a/lib/WebGUI/Middleware/Debug.pm b/lib/WebGUI/Middleware/Debug.pm deleted file mode 100644 index 6098687bc..000000000 --- a/lib/WebGUI/Middleware/Debug.pm +++ /dev/null @@ -1,39 +0,0 @@ -package WebGUI::Middleware::Debug; -use strict; -use parent qw(Plack::Middleware); -use Plack::Middleware::StackTrace; -use Plack::Middleware::Debug; -use Plack::Middleware::HttpExceptions; - -=head1 NAME - -WebGUI::Middleware::Debug - - -=head1 DESCRIPTION - -This is PSGI middleware for WebGUI that - -=cut - -sub call { - my ( $self, $env ) = @_; - - my $session = $env->{'webgui.session'} or die 'WebGUI::Session missing'; - - my $app = $self->app; - - if ( $session->log->canShowDebug ) { - warn 'seeing webgui.debug'; - $env->{'webgui.debug'} = 1; - $app = Plack::Middleware::StackTrace->wrap($app); - $app = Plack::Middleware::Debug->wrap( $app, - panels => [qw(Environment Response Timer Memory Session DBITrace PerlConfig Response)] ); - } - - # Turn exceptions into HTTP errors - $app = Plack::Middleware::HTTPExceptions->wrap( $app ); - - return $app->($env); -} - -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 index 069bc3506..b847adc9d 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -6,7 +6,7 @@ use WebGUI::Session; use Try::Tiny; use Plack::Middleware::StackTrace; use Plack::Middleware::Debug; -use Plack::Middleware::HTTPExceptions; +use WebGUI::Middleware::HTTPExceptions; use Plack::Middleware::ErrorDocument; use Plack::Util::Accessor qw( config error_docs ); @@ -31,20 +31,19 @@ and not worry about closing it. sub call { my ( $self, $env ) = @_; - my $app = $self->app; + my $app = $self->app; my $config = $self->config or die 'Mandatory config parameter missing'; my $session = try { $env->{'webgui.session'} = WebGUI::Session->open( $config->getWebguiRoot, $config, $env ); }; - - if (!$session) { + + 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 # (using the error_docs mapping) - return Plack::Middleware::ErrorDocument->wrap( - sub { [ 500, [], [] ] }, - %{ $self->error_docs } )->($env); + return Plack::Middleware::ErrorDocument->wrap( sub { [ 500, [], [] ] }, %{ $self->error_docs } )->($env); } my $debug = $session->log->canShowDebug; @@ -55,7 +54,7 @@ sub call { } # Turn exceptions into HTTP errors - $app = Plack::Middleware::HTTPExceptions->wrap($app); + $app = WebGUI::Middleware::HTTPExceptions->wrap($app); # HTTP error document mapping if ( !$debug && $self->error_docs ) { diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 783247567..f14713f51 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -257,8 +257,10 @@ If this problem persists, please contact us with what you were trying to do and END_HTML } - # Fatal errors cause an exception to be thrown - WebGUI::Error->throw( error => $error ); + # Fatal errors cause an exception to be thrown - use WebGUI::Error::Fatal so + # that WebGUI knows to show this error message to all site users (instead of showing + # non-debug users the generic error screen) + WebGUI::Error::Fatal->throw( error => $error ); } From 7ef963e74f44f3db29bb15d440025700880ea020 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 13 Apr 2010 17:27:18 -0400 Subject: [PATCH 38/92] Logging fallback --- README | 2 +- benchmark.pl | 12 +++++++----- eg/dev.localhost.localdomain.fcgi | 2 +- lib/WebGUI/Middleware/Session.pm | 6 ++++++ lib/WebGUI/Session/ErrorHandler.pm | 19 ++++++++++++++++++- 5 files changed, 33 insertions(+), 8 deletions(-) diff --git a/README b/README index 1854a0459..62971c023 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ This is the PSGI branch of WebGUI8 Currently, the best performance is achieved via: - plackup -E none -s Starman --workers 10 + plackup -E none -s Starman --workers 10 --disable-keepalive You can benchmark your server via: diff --git a/benchmark.pl b/benchmark.pl index e269ba619..fa71b1dc4 100755 --- a/benchmark.pl +++ b/benchmark.pl @@ -1,17 +1,19 @@ # Little script used to run benchmarks against dev.localhost.localdomain # # To profile, run "perl -d:NYTProf benchmark.pl" -use Devel::Leak::Object qw(GLOBAL_bless); -$Devel::Leak::Object::TRACKSOURCELINES = 1; 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 = $wg->psgi_app; +my $app = builder { + enable '+WebGUI::Middleware::Session', config => $wg->config; + $wg; +}; test_psgi $app, sub { my $cb = shift; - my $res = $cb->( GET "/" ); -} for 1..100; \ No newline at end of file + $cb->( GET "/" ) for 1..1000; +}; \ No newline at end of file diff --git a/eg/dev.localhost.localdomain.fcgi b/eg/dev.localhost.localdomain.fcgi index 431274292..ca633fef5 100755 --- a/eg/dev.localhost.localdomain.fcgi +++ b/eg/dev.localhost.localdomain.fcgi @@ -1,5 +1,5 @@ #!/usr/bin/perl use Plack::Server::FCGI; -my $app = Plack::Util::load_psgi("/data/WebGUI/etc/dev.localhost.localdomain.psgi"); +my $app = Plack::Util::load_psgi("../app.psgi"); Plack::Server::FCGI->new->run($app); diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index b847adc9d..3f70cf908 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -8,6 +8,7 @@ use Plack::Middleware::StackTrace; use Plack::Middleware::Debug; use WebGUI::Middleware::HTTPExceptions; use Plack::Middleware::ErrorDocument; +use Plack::Middleware::SimpleLogger; use Plack::Util::Accessor qw( config error_docs ); @@ -33,6 +34,11 @@ sub call { 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->getWebguiRoot, $config, $env ); diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index f14713f51..a2ad0e913 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -274,7 +274,24 @@ Returns a reference to the logger. sub getLogger { my $self = shift; - return $self->session->request->logger; + if ($self->session->request) { + return $self->session->request->logger; + } else { + + # 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) + if (!$self->{_logger}) { + Log::Log4perl->init_once( $self->session->config->getWebguiRoot."/etc/log.conf" ); + my $logger = Log::Log4perl->get_logger($self->session->config->getFilename); + $self->{_logger} = sub { + my $args = shift; + my $level = $args->{level}; + $logger->$level($args->{message}); + }; + } + return $self->{_logger}; + } } From 82ce3331b738b5ac062e9b50c287559e32d9470d Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 13 Apr 2010 18:50:03 -0400 Subject: [PATCH 39/92] Added tests for WebGUI PSGI app exceptions --- lib/WebGUI/Middleware/Session.pm | 9 +++- lib/WebGUI/Session/ErrorHandler.pm | 44 +++++++--------- t/Exception/app.t | 85 ++++++++++++++++++++++++++++++ 3 files changed, 113 insertions(+), 25 deletions(-) create mode 100644 t/Exception/app.t diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 3f70cf908..37eb67fac 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -42,6 +42,9 @@ sub call { my $session = try { $env->{'webgui.session'} = WebGUI::Session->open( $config->getWebguiRoot, $config, $env ); + } catch { + # We don't have a logger object, so for now just warn() the error + warn "Unable to instantiate WebGUI::Session - $_"; }; if ( !$session ) { @@ -49,7 +52,11 @@ sub call { # 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 # (using the error_docs mapping) - return Plack::Middleware::ErrorDocument->wrap( sub { [ 500, [], [] ] }, %{ $self->error_docs } )->($env); + if ($self->error_docs) { + return Plack::Middleware::ErrorDocument->wrap( sub { [ 500, [], [] ] }, %{ $self->error_docs } )->($env); + } else { + return [ 500, [ 'Content-Type' => 'text/plain' ], [ 'Internal Server Error' ] ]; + } } my $debug = $session->log->canShowDebug; diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index a2ad0e913..682f7072f 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -272,27 +272,7 @@ Returns a reference to the logger. =cut -sub getLogger { - my $self = shift; - if ($self->session->request) { - return $self->session->request->logger; - } else { - - # 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) - if (!$self->{_logger}) { - Log::Log4perl->init_once( $self->session->config->getWebguiRoot."/etc/log.conf" ); - my $logger = Log::Log4perl->get_logger($self->session->config->getFilename); - $self->{_logger} = sub { - my $args = shift; - my $level = $args->{level}; - $logger->$level($args->{message}); - }; - } - return $self->{_logger}; - } -} +sub getLogger { $_[0]->{_logger} } #------------------------------------------------------------------- @@ -349,9 +329,25 @@ An active WebGUI::Session object. =cut sub new { - my $class = shift; - my $session = shift; - bless {_queryCount=>0, _session=>$session}, $class; + my $class = shift; + my $session = shift; + + 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) + Log::Log4perl->init_once( $session->config->getWebguiRoot . "/etc/log.conf" ); + my $log4perl = Log::Log4perl->get_logger( $session->config->getFilename ); + $logger = sub { + my $args = shift; + my $level = $args->{level}; + $log4perl->$level( $args->{message} ); + }; + } + + bless { _queryCount => 0, _session => $session, _logger => $logger }, $class; } #---------------------------------------------------------------------------- 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/; +}; + From b1ab8287ca5a960c25ac3879f5ce64c12d77f075 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 13 Apr 2010 19:33:35 -0400 Subject: [PATCH 40/92] Added WebGUI::Middleware::WGAccess for .wgaccess-aware static serving on dev servers --- app.psgi | 3 + lib/Plack/Middleware/WGAccess.pm | 92 ------------------------------- lib/WebGUI/Middleware/WGAccess.pm | 69 +++++++++++++++++++++++ 3 files changed, 72 insertions(+), 92 deletions(-) delete mode 100644 lib/Plack/Middleware/WGAccess.pm create mode 100644 lib/WebGUI/Middleware/WGAccess.pm diff --git a/app.psgi b/app.psgi index d42c34d7a..902dd0e6b 100644 --- a/app.psgi +++ b/app.psgi @@ -16,6 +16,9 @@ builder { config => $wg->config, error_docs => { 500 => "$root/www/maintenance.html" }; + # This one uses the Session object, so it comes after WebGUI::Middleware::Session + enable '+WebGUI::Middleware::WGAccess', config => $wg->config; + # Return the app $wg; }; diff --git a/lib/Plack/Middleware/WGAccess.pm b/lib/Plack/Middleware/WGAccess.pm deleted file mode 100644 index 4308a0b84..000000000 --- a/lib/Plack/Middleware/WGAccess.pm +++ /dev/null @@ -1,92 +0,0 @@ -package Plack::Middleware::WGAccess; -use strict; -use warnings; -use base qw/Plack::Middleware::Static/; -use Path::Class 'dir'; - -=head1 NAME - -Plack::Middleware::WGAccess - -=head1 DESCRIPTION - -Plack Middleware that delivers static files with .wgaccess awareness - -=cut - -sub _handle_static { - my($self, $env) = @_; - - ####################################### - # Copied from Plack::Middleware::Static::_handle_static - - my $path_match = $self->path or return; - - if ($env->{PATH_INFO} =~ m!\.\.[/\\]!) { - return $self->return_403; - } - - my $path = do { - my $matched; - local $_ = $env->{PATH_INFO}; - if (ref $path_match eq 'CODE') { - $matched = $path_match->($_); - } else { - $matched = $_ =~ $path_match; - } - return unless $matched; - $_; - } or return; - - my $docroot = dir($self->root || "."); - my $file = $docroot->file(File::Spec::Unix->splitpath($path)); - my $realpath = Cwd::realpath($file->absolute->stringify); - - # Is the requested path within the root? - if ($realpath && !$docroot->subsumes($realpath)) { - return $self->return_403; - } - - # Does the file actually exist? - if (!$realpath || !-f $file) { - return $self->return_404; - } - - # If the requested file present but lacking the permission to read it? - if (!-r $file) { - return $self->return_403; - } - - ############################### - # Copied from WebGUI::URL::Uploads - my $wgaccess = File::Spec::Unix->catfile($file->dir, '.wgaccess'); - if (-e $wgaccess) { - my $fileContents; - open(my $FILE, "<", $wgaccess); - while (my $line = <$FILE>) { - $fileContents .= $line; - } - close($FILE); - my @privs = split("\n", $fileContents); - unless ($privs[1] eq "7" || $privs[1] eq "1") { - my $request = Plack::Request->new( $env ); - -# my $session = $request->pnotes('wgSession'); - unless (defined $session) { -# $session = WebGUI::Session->open($env->{dir_config('WebguiRoot'), $request->dir_config('WebguiConfig'), $request ); - } - my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); - $session->close(); - if ($hasPrivs) { - return $self->SUPER::_handle_static($env); # serve statically - } - else { - return $self->return_403; - } - } - } else { - return $self->SUPER::_handle_static($env); # serve statically - } -} - -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..ba5d3d179 --- /dev/null +++ b/lib/WebGUI/Middleware/WGAccess.pm @@ -0,0 +1,69 @@ +package WebGUI::Middleware::WGAccess; +use strict; +use Plack::App::File; +use parent qw(Plack::Middleware); +use Path::Class 'dir'; + +=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 + +use Plack::Util::Accessor qw( config ); + +sub call { + my $self = shift; + my $env = shift; + my $app = $self->app; + my $config = $self->config or die 'Mandatory config parameter missing'; + my $uploadsPath = $config->get('uploadsPath'); + my $uploadsURL = $config->get('uploadsURL'); + + my $path = $env->{PATH_INFO}; + my $matched = $path =~ s{^\Q$uploadsURL\E/}{}; + return $app->($env) unless $matched; + + my $root = dir($uploadsPath); + my $file = $root->file(File::Spec::Unix->splitpath($path)); + my $wgaccess = File::Spec::Unix->catfile($file->dir, '.wgaccess'); + + if (-e $wgaccess) { + my $fileContents; + open(my $FILE, "<", $wgaccess); + while (my $line = <$FILE>) { + $fileContents .= $line; + } + close($FILE); + my @privs = split("\n", $fileContents); + + unless ($privs[1] eq "7" || $privs[1] eq "1") { + my $session = $env->{'webgui.session'}; + my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); + warn "has: $hasPrivs"; + warn $session->var->get("userId"); + warn $session->user->isInGroup($privs[1]); + warn $session->user->isInGroup($privs[2]); + if ($hasPrivs) { + $self->{file} ||= Plack::App::File->new; + return $self->{file}->serve_path($env, $file); # serve statically + } + else { + return [403, ['Content-Type' => 'text/plain'], ['Forbidden']]; + } + } + } + + $self->{file} ||= Plack::App::File->new; + return $self->{file}->serve_path($env, $file); # serve statically +} + +1; \ No newline at end of file From 2d7c8e637fe7502c09ea9e92bd770ce03f94735c Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 13 Apr 2010 21:00:08 -0400 Subject: [PATCH 41/92] Adds Plack::Middleware::Debug::WgLogger --- lib/Plack/Middleware/Debug/WgLogger.pm | 31 ++++++++++++++++++++++++++ lib/WebGUI/Middleware/Session.pm | 2 +- 2 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 lib/Plack/Middleware/Debug/WgLogger.pm diff --git a/lib/Plack/Middleware/Debug/WgLogger.pm b/lib/Plack/Middleware/Debug/WgLogger.pm new file mode 100644 index 000000000..94d0e2d51 --- /dev/null +++ b/lib/Plack/Middleware/Debug/WgLogger.pm @@ -0,0 +1,31 @@ +package Plack::Middleware::Debug::WgLogger; +use strict; +use parent qw(Plack::Middleware::Debug::Base); +our $VERSION = '0.07'; + +# This will be moved to the WebGUI::Middleware::Debug::WgLogger namespace +# once Plack::Middleware::Debug supports that + +sub run { + my ($self, $env, $panel) = @_; + + my $logger = $env->{'psgix.logger'}; + + my $log_output = []; + $env->{'psgix.logger'} = sub { + my $args = shift; + push @$log_output, $args->{level} => $args->{message}; + $logger && $logger->($args); + }; + delete $env->{'webgui.session'}->{_errorHandler}; + + return sub { + my $res = shift; + $panel->nav_subtitle(scalar @$log_output . " messages"); + $panel->content($self->render_list_pairs($log_output)); + }; +} + +sub panel_name { 'WebGUI Log' } + +1; \ No newline at end of file diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 37eb67fac..5deb0189f 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -63,7 +63,7 @@ sub call { if ($debug) { $app = Plack::Middleware::StackTrace->wrap($app); $app = Plack::Middleware::Debug->wrap( $app, - panels => [qw(Environment Response Timer Memory Session DBITrace PerlConfig Response)] ); + panels => [qw(Environment Response Timer Memory Session DBITrace PerlConfig Response WgLogger)] ); } # Turn exceptions into HTTP errors From 9b4e67b828c929d3daa1dbab9e6cc92263d66868 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 13 Apr 2010 21:17:15 -0400 Subject: [PATCH 42/92] Removed showDebug() in favour of new logger panel --- lib/WebGUI.pm | 6 ------ lib/WebGUI/Session/ErrorHandler.pm | 2 ++ 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 33733f932..6270c0607 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -212,9 +212,6 @@ sub handle { # "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"; - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); - } return; } # non-empty output should be used as the response body @@ -224,9 +221,6 @@ sub handle { # Use contentHandler's return value as the output $session->output->print($output); - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); - } return; } # Keep processing for success codes diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 682f7072f..e6f5352de 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -447,6 +447,8 @@ sub session { Creates an HTML formatted string of all internally stored debug information, warns, errors, sql queries and form data. +THIS METHOD IS DEPRECATED (See Plack::Middleware::Debug::WgLogger) + =cut sub showDebug { From 30a2c09a36f85e64ecf2a3288cc325bc0f227255 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Wed, 14 Apr 2010 16:25:10 -0400 Subject: [PATCH 43/92] URL handlers are now completely replaced by Middleware --- README | 2 +- app.psgi | 9 ++++ lib/WebGUI.pm | 35 ++----------- lib/WebGUI/Middleware/Session.pm | 5 ++ lib/WebGUI/Middleware/Snoop.pm | 34 ++++++++++++ lib/WebGUI/URL/Credits.pm | 65 ----------------------- lib/WebGUI/URL/PassThru.pm | 59 --------------------- lib/WebGUI/URL/Snoop.pm | 61 ---------------------- lib/WebGUI/URL/Unauthorized.pm | 54 -------------------- lib/WebGUI/URL/Uploads.pm | 88 -------------------------------- lib/WebGUI/URL/_url.skeleton | 55 -------------------- 11 files changed, 53 insertions(+), 414 deletions(-) create mode 100644 lib/WebGUI/Middleware/Snoop.pm delete mode 100644 lib/WebGUI/URL/Credits.pm delete mode 100644 lib/WebGUI/URL/PassThru.pm delete mode 100644 lib/WebGUI/URL/Snoop.pm delete mode 100644 lib/WebGUI/URL/Unauthorized.pm delete mode 100644 lib/WebGUI/URL/Uploads.pm delete mode 100644 lib/WebGUI/URL/_url.skeleton diff --git a/README b/README index 62971c023..054eb5dd2 100644 --- a/README +++ b/README @@ -8,7 +8,7 @@ You can benchmark your server via: ab -t 3 -c 10 -k http://dev.localhost.localdomain:5000/ | grep Req -I'm currently getting 23 requests/second, whereas I'm getting 30/second on the non-PSGI WebGUI8 branch. +I'm currently getting 370 requests/second, whereas I'm getting 430/second on the non-PSGI WebGUI8 branch. = ARCHITECTURE = diff --git a/app.psgi b/app.psgi index 902dd0e6b..a8fda4126 100644 --- a/app.psgi +++ b/app.psgi @@ -9,7 +9,16 @@ my $wg = WebGUI->new( root => $root, site => 'dev.localhost.localdomain.conf' ); builder { enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; + + # Reproduce URL handler functionality with middleware + enable '+WebGUI::Middleware::Snoop'; enable 'Static', root => $root, path => sub { s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt} }; + 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) = ( $wg->config->get('extrasURL'), $wg->config->get('extrasPath') ); + enable 'Static', root => "$extrasPath/", path => sub { s{^$extrasURL/}{} }; # Open/close the WebGUI::Session at the outer-most onion layer enable '+WebGUI::Middleware::Session', diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 6270c0607..48f42f839 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -84,11 +84,9 @@ sub psgi_app { sub compile_psgi_app { my $self = shift; - my $catch = [ 500, [ 'Content-Type' => 'text/plain' ], [ "Internal Server Error" ] ]; - # WebGUI is a PSGI app is a Perl code reference. Let's create one. # Each web request results in a call to this sub - my $app = sub { + return sub { my $env = shift; # Use the PSGI callback style response, which allows for nice things like @@ -99,7 +97,7 @@ sub compile_psgi_app { my $session = $env->{'webgui.session'} or die 'Missing WebGUI Session - check WebGUI::Middleware::Session'; # Handle the request - $self->handle($session); + handle($session); # Construct the PSGI response my $response = $session->response; @@ -128,12 +126,11 @@ sub compile_psgi_app { $session->request->TRACE("Error detected after streaming response started"); $response->writer->close; } else { - $responder->( $catch ); + $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. @@ -141,34 +138,10 @@ sub compile_psgi_app { } } }; - - # Wrap $app with some extra middleware that acts as a fallback for when - # you're not using something fast to serve static content - # - # This could also be in the .psgi file, but it seems sensible to have it - # baked in as a fallback (unless we find it drains performance) - my $config = $self->config; - - # Extras - use Plack::Middleware::Static; - my $extrasURL = $config->get('extrasURL'); - my $extrasPath = $config->get('extrasPath'); - $app = Plack::Middleware::Static->wrap($app, - path => sub { s{^$extrasURL/}{} }, - root => "$extrasPath/", - ); - - # Uploads - my $uploadsURL = $config->get('uploadsURL'); - my $uploadsPath = $config->get('uploadsPath'); - $app = Plack::Middleware::Static->wrap($app, - path => sub { s{^$uploadsURL/}{} }, - root => "$uploadsPath/", - ); } sub handle { - my ( $self, $session ) = @_; + my ( $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"); diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 5deb0189f..ab9d8f3d1 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -45,6 +45,7 @@ sub call { } 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 ) { @@ -85,7 +86,11 @@ sub call { # Close the Session $env->{'webgui.session'}->close(); + #memory_cycle_ok( $env->{'webgui.session'} ); delete $env->{'webgui.session'}; + + #use Test::Memory::Cycle; + #memory_cycle_ok( $env ); } ); } 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/URL/Credits.pm b/lib/WebGUI/URL/Credits.pm deleted file mode 100644 index 735e31e3a..000000000 --- a/lib/WebGUI/URL/Credits.pm +++ /dev/null @@ -1,65 +0,0 @@ -package WebGUI::URL::Credits; - -=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 APR::Finfo (); -use APR::Const -compile => qw(FINFO_NORM); -use WebGUI::Session; - -=head1 NAME - -Package WebGUI::URL::Credits - -=head1 DESCRIPTION - -A URL handler that displays the credits file. - -=head1 SYNOPSIS - - use WebGUI::URL::Credits; - my $status = WebGUI::URL::Credits::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) = @_; - my $filename = $config->getWebguiRoot."/docs/credits.txt"; - $request->push_handlers(PerlResponseHandler => sub { - $request->content_type('text/plain'); - $request->sendfile($filename); - return Apache2::Const::OK; - }); - $request->push_handlers(PerlTransHandler => sub { return Apache2::Const::OK }); - $request->push_handlers(PerlMapToStorageHandler => 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 e96e4ec84..000000000 --- a/lib/WebGUI/URL/Uploads.pm +++ /dev/null @@ -1,88 +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 { - if (-e $request->filename) { - my $path = $request->filename; - $path =~ s/^(\/.*\/).*$/$1/; - if (-e $path.".wgaccess") { - my $fileContents; - open(my $FILE, "<" ,$path.".wgaccess"); - while (my $line = <$FILE>) { - $fileContents .= $line; - } - close($FILE); - my @privs = split("\n", $fileContents); - unless ($privs[1] eq "7" || $privs[1] eq "1") { - my $session = $request->pnotes('wgSession'); - unless (defined $session) { -# $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request); - } - my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); - $session->close(); - if ($hasPrivs) { - return Apache2::Const::OK; - } - else { - return Apache2::Const::AUTH_REQUIRED; - } - } - } - return Apache2::Const::OK; - } - else { - return Apache2::Const::NOT_FOUND; - } - } ); - 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 From 4d703ffd479d15db09fb2b0e1e9cd515d0636ac3 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Wed, 14 Apr 2010 19:36:41 -0400 Subject: [PATCH 44/92] Added preloading Removed evil overload Removed references to Apache2:: from codebase Attempted to remove circular references --- app.psgi | 9 +-- lib/WebGUI.pm | 59 ++++++++++++++++++- lib/WebGUI/Asset/Wobject/HttpProxy.pm | 1 - lib/WebGUI/Macro/UsersOnline.pm | 1 - lib/WebGUI/Middleware/Session.pm | 6 ++ lib/WebGUI/Storage.pm | 2 - .../Workflow/Activity/SendWebguiStats.pm | 3 +- 7 files changed, 68 insertions(+), 13 deletions(-) diff --git a/app.psgi b/app.psgi index a8fda4126..f99b64ccc 100644 --- a/app.psgi +++ b/app.psgi @@ -5,6 +5,7 @@ use WebGUI; my $root = '/data/WebGUI'; my $wg = WebGUI->new( root => $root, site => 'dev.localhost.localdomain.conf' ); +my $config = $wg->config; builder { @@ -17,17 +18,17 @@ builder { # For PassThru, use Plack::Builder::mount # Extras fallback (you should be using something else to serve static files in production) - my ($extrasURL, $extrasPath) = ( $wg->config->get('extrasURL'), $wg->config->get('extrasPath') ); + my ($extrasURL, $extrasPath) = ( $config->get('extrasURL'), $config->get('extrasPath') ); enable 'Static', root => "$extrasPath/", path => sub { s{^$extrasURL/}{} }; # Open/close the WebGUI::Session at the outer-most onion layer enable '+WebGUI::Middleware::Session', - config => $wg->config, + config => $config, error_docs => { 500 => "$root/www/maintenance.html" }; # This one uses the Session object, so it comes after WebGUI::Middleware::Session - enable '+WebGUI::Middleware::WGAccess', config => $wg->config; + enable '+WebGUI::Middleware::WGAccess', config => $config; # Return the app - $wg; + $wg->psgi_app; }; diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 48f42f839..a7e376531 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -74,8 +74,6 @@ sub BUILD { $self->config($config); } -use overload q(&{}) => sub { shift->psgi_app }, fallback => 1; - sub psgi_app { my $self = shift; return $self->{psgi_app} ||= $self->compile_psgi_app; @@ -84,6 +82,10 @@ sub psgi_app { sub compile_psgi_app { my $self = shift; + # Preload all modules in the master (parent) thread before the Server does any + # child forking. This should save a lot of memory in copy-on-write friendly environments. + $self->preload; + # WebGUI is a PSGI app is a Perl code reference. Let's create one. # Each web request results in a call to this sub return sub { @@ -138,7 +140,58 @@ sub compile_psgi_app { } } }; -} +} + +sub preload { + my $self = shift; + my $debug = shift; + + warn 'Preloading modules..' if $debug; + my $modules = sub { + require Module::Versions; + my $m = Module::Versions->HASH; + $_ = $_->{VERSION} for values %$m; + return $m; + } if $debug; + my $pre = $modules->() if $debug; + + # The following is taken from preload.perl + my $readlines = sub { + my $file = shift; + my @lines; + if (open(my $fh, '<', $file)) { + while (my $line = <$fh>) { + $line =~ s/#.*//; + $line =~ s/^\s+//; + $line =~ s/\s+$//; + next if !$line; + push @lines, $line; + } + close $fh; + } + return @lines; + }; + + my @excludes = $readlines->($self->root . '/sbin/preload.exclude'); + + use DBI; + DBI->install_driver("mysql"); + WebGUI::Pluggable::findAndLoad( "WebGUI", + { + exclude => \@excludes, + onLoadFail => sub { die 'Error loading %s: %s', @_ }, + } + ); + + if ($debug) { + my $post = $modules->(); + my @new; + for my $k (keys %$post) { + push @new, $k unless $pre->{$k}; + } + warn join "\n", sort @new; + } +} sub handle { my ( $session ) = @_; diff --git a/lib/WebGUI/Asset/Wobject/HttpProxy.pm b/lib/WebGUI/Asset/Wobject/HttpProxy.pm index 1b1d54c6f..6bca2c787 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; diff --git a/lib/WebGUI/Macro/UsersOnline.pm b/lib/WebGUI/Macro/UsersOnline.pm index 2516b1835..39ecbd892 100644 --- a/lib/WebGUI/Macro/UsersOnline.pm +++ b/lib/WebGUI/Macro/UsersOnline.pm @@ -19,7 +19,6 @@ package WebGUI::Macro::UsersOnline; =cut use strict; -use Apache2::ServerRec; use Net::DNS; use WebGUI::Asset::Template; use WebGUI::International; diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index ab9d8f3d1..c123d5d22 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -9,6 +9,7 @@ use Plack::Middleware::Debug; use WebGUI::Middleware::HTTPExceptions; use Plack::Middleware::ErrorDocument; use Plack::Middleware::SimpleLogger; +use Scalar::Util qw(weaken); use Plack::Util::Accessor qw( config error_docs ); @@ -33,6 +34,8 @@ sub call { my ( $self, $env ) = @_; my $app = $self->app; + weaken $self->{config}; + my $config = $self->config or die 'Mandatory config parameter missing'; # Logger fallback @@ -59,6 +62,9 @@ sub call { return [ 500, [ 'Content-Type' => 'text/plain' ], [ 'Internal Server Error' ] ]; } } + + # Perhaps I'm being paranoid.. + weaken $session->{_config}; my $debug = $session->log->canShowDebug; if ($debug) { diff --git a/lib/WebGUI/Storage.pm b/lib/WebGUI/Storage.pm index fafa38596..dbb50193f 100644 --- a/lib/WebGUI/Storage.pm +++ b/lib/WebGUI/Storage.pm @@ -363,8 +363,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)) { 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"), From 72854549cde7a9957a21ad033ef87dba50a22f53 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Thu, 15 Apr 2010 11:00:06 -0400 Subject: [PATCH 45/92] Multi-site support --- app.psgi | 80 +++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 56 insertions(+), 24 deletions(-) diff --git a/app.psgi b/app.psgi index f99b64ccc..dc644af78 100644 --- a/app.psgi +++ b/app.psgi @@ -4,31 +4,63 @@ use lib '/data/WebGUI/lib'; use WebGUI; my $root = '/data/WebGUI'; -my $wg = WebGUI->new( root => $root, site => 'dev.localhost.localdomain.conf' ); -my $config = $wg->config; builder { + mount "http://dev.localhost.localdomain/" => builder { + + my $wg = WebGUI->new( root => $root, site => 'dev.localhost.localdomain.conf' ); + my $config = $wg->config; + enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; + + # Reproduce URL handler functionality with middleware + enable '+WebGUI::Middleware::Snoop'; + enable 'Static', root => $root, path => sub {s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt}}; + 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{^$extrasURL/}{}}; + + # Open/close the WebGUI::Session at the outer-most onion layer + enable '+WebGUI::Middleware::Session', + config => $config, + error_docs => { 500 => "$root/www/maintenance.html" }; + + # This one uses the Session object, so it comes after WebGUI::Middleware::Session + enable '+WebGUI::Middleware::WGAccess', config => $config; + + # Return the app + $wg->psgi_app; + }; - enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; - - # Reproduce URL handler functionality with middleware - enable '+WebGUI::Middleware::Snoop'; - enable 'Static', root => $root, path => sub { s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt} }; - 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{^$extrasURL/}{} }; - - # Open/close the WebGUI::Session at the outer-most onion layer - enable '+WebGUI::Middleware::Session', - config => $config, - error_docs => { 500 => "$root/www/maintenance.html" }; - - # This one uses the Session object, so it comes after WebGUI::Middleware::Session - enable '+WebGUI::Middleware::WGAccess', config => $config; - - # Return the app - $wg->psgi_app; + mount "http://dev2.localhost.localdomain/" => builder { + + my $wg = WebGUI->new( root => $root, site => 'dev2.localhost.localdomain.conf' ); + my $config = $wg->config; + enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; + + # Reproduce URL handler functionality with middleware + enable '+WebGUI::Middleware::Snoop'; + enable 'Static', root => $root, path => sub {s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt}}; + 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{^$extrasURL/}{}}; + + # Open/close the WebGUI::Session at the outer-most onion layer + enable '+WebGUI::Middleware::Session', + config => $config, + error_docs => { 500 => "$root/www/maintenance.html" }; + + # This one uses the Session object, so it comes after WebGUI::Middleware::Session + enable '+WebGUI::Middleware::WGAccess', config => $config; + + # Return the app + $wg->psgi_app; + }; }; From 0c08e9c23521548a444f005307d8730e8de17585 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 13 Apr 2010 19:19:36 -0500 Subject: [PATCH 46/92] simplify logging and move inline debug into plack middleware --- lib/Plack/Middleware/Debug/Logger.pm | 45 ++++++ lib/Plack/Middleware/Debug/MySQLTrace.pm | 103 ++++++++++++ lib/WebGUI/Middleware/Session.pm | 13 +- lib/WebGUI/Session/ErrorHandler.pm | 198 ++++------------------- 4 files changed, 190 insertions(+), 169 deletions(-) create mode 100644 lib/Plack/Middleware/Debug/Logger.pm create mode 100644 lib/Plack/Middleware/Debug/MySQLTrace.pm diff --git a/lib/Plack/Middleware/Debug/Logger.pm b/lib/Plack/Middleware/Debug/Logger.pm new file mode 100644 index 000000000..d1fea0017 --- /dev/null +++ b/lib/Plack/Middleware/Debug/Logger.pm @@ -0,0 +1,45 @@ +package Plack::Middleware::Debug::Logger; +use 5.008; +use strict; +use warnings; +use parent qw(Plack::Middleware::Debug::Base); +use Sub::Uplevel (); +our $VERSION = '0.07'; + +sub run { + my ($self, $env, $panel) = @_; + + my $wrap_logger = $env->{'psgix.logger'}; + my %output; + $env->{'psgix.logger'} = sub { + my ($args) = @_; + my $caller = (caller(1))[3] . '[' . (caller(0))[2] . '] '; + my $message = $args->{message}; + $message =~ s/\n\s*/\n /msxg; + $message =~ s/\n?\z/\n/msx; + $output{lc $args->{level}} ||= ''; + $output{lc $args->{level}} .= $caller . $message; + if ($wrap_logger) { + Sub::Uplevel::uplevel 1, $wrap_logger, @_; + } + }; + + return sub { + my $res = shift; + + if ($wrap_logger) { + $env->{'psgix.logger'} = $wrap_logger; + } + my $content = ''; + for my $level ( qw(info debug warn error fatal) ) { + if ($output{$level}) { + $content .= "

\u$level

"; + $content .= '
' . $self->render_lines($output{$level}) . '
'; + } + } + $panel->content($content); + }; +} + +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/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index c123d5d22..2165e14b4 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -70,7 +70,18 @@ sub call { if ($debug) { $app = Plack::Middleware::StackTrace->wrap($app); $app = Plack::Middleware::Debug->wrap( $app, - panels => [qw(Environment Response Timer Memory Session DBITrace PerlConfig Response WgLogger)] ); + panels => [ + 'Environment', + 'Response', + 'Timer', + 'Memory', + 'Session', + 'PerlConfig', + [ 'MySQLTrace', skip_packages => qr/\AWebGUI::SQL(?:\z|::)/ ], + 'Response', + 'Logger', + ], + ); } # Turn exceptions into HTTP errors diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 6e2fc5c42..9c4e24421 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -70,9 +70,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); + my $self = shift; + my $message = shift; + @_ = ($self->session->user->username." (".$self->session->user->userId.") ".$message); + goto $self->can('info'); } @@ -161,29 +162,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 + 2; - $self->getLogger->({ level => 'debug', message => $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 +181,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 + 2; - $self->getLogger->({ level => 'error', message => $message}); - $self->getLogger->({ level => 'debug', message => "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,49 +201,10 @@ The message to use. =cut sub fatal { - my $self = shift; - my $message = shift; - - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; - $self->getLogger->({ level => 'fatal', message => $message }); - $self->getLogger->({ level => 'debug', message => "Stack trace for FATAL ".$message."\n".$self->getStackTrace() }); - - my $error; - if (! defined $self->session->db(1)) { - # We can't even _determine_ whether we can show the debug text. Punt. - $error = q{

Fatal Internal Error

}; - } - elsif ($self->canShowDebug()) { - my $stack = encode_entities($self->getStackTrace); - my $debug = $self->showDebug(); - $error = <WebGUI Fatal Error -

Something unexpected happened that caused this system to fault.

-

$message

-
$stack
-$debug -END_HTML - } - else { - # NOTE: You can't internationalize this because with some types of errors that would cause an infinite loop. - my $company = $self->session->setting->get("companyName"); - my $email = $self->session->setting->get("companyEmail"); - my $url = $self->session->setting->get("companyURL"); - - $error = <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.
-
$company -
$email -
$url -END_HTML - } - - # Fatal errors cause an exception to be thrown - use WebGUI::Error::Fatal so - # that WebGUI knows to show this error message to all site users (instead of showing - # non-debug users the generic error screen) - WebGUI::Error::Fatal->throw( error => $error ); + my $self = shift; + my $message = shift; + @_ = ({ level => 'fatal', message => $message}); + goto $self->getLogger; } @@ -310,11 +253,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 + 2; - $self->getLogger->({ level => 'info', message => $message }); - $self->{_debug_info} .= $message."\n"; + my $self = shift; + my $message = shift; + @_ = ({ level => 'info', message => $message}); + goto $self->getLogger; } #------------------------------------------------------------------- @@ -349,7 +291,7 @@ sub new { }; } - bless { _queryCount => 0, _session => $session, _logger => $logger }, $class; + bless { _session => $session, _logger => $logger }, $class; } #---------------------------------------------------------------------------- @@ -368,47 +310,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; # TODO - re-enable || $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 + 2; - $self->getLogger->({ level => 'debug', message => "query $self->{_queryCount}:\n$query$plac" }); -} - - - #------------------------------------------------------------------- =head2 security ( message ) @@ -422,10 +323,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->session->user->username." (".$self->session->user->userId.") connecting from " + .$self->session->env->getIp." attempted to ".$message); + goto $self->can('warn'); } @@ -442,45 +344,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. - -THIS METHOD IS DEPRECATED (See Plack::Middleware::Debug::WgLogger) - -=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; -} - - #------------------------------------------------------------------- @@ -495,11 +358,10 @@ 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 + 2; - $self->getLogger->({ level => 'warn', message => $message }); - $self->{_debug_warn} .= $message."\n"; + my $self = shift; + my $message = shift; + @_ = ({ level => 'warn', message => $message}); + goto $self->getLogger; } From 5b2569256123458cfd46a4c6dba66377a0b68e57 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 17 Sep 2009 05:01:10 -0500 Subject: [PATCH 47/92] first shot at DBI tracing code --- lib/WebGUI/SQL.pm | 8 ++++-- lib/WebGUI/SQL/ResultSet.pm | 4 +-- lib/WebGUI/SQL/Trace.pm | 55 +++++++++++++++++++++++++++++++++++++ 3 files changed, 62 insertions(+), 5 deletions(-) create mode 100644 lib/WebGUI/SQL/Trace.pm diff --git a/lib/WebGUI/SQL.pm b/lib/WebGUI/SQL.pm index b13d5a165..c3ed2cf2b 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -203,7 +203,6 @@ sub buildHashRef { 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) { @@ -428,10 +427,15 @@ sub connect { my $pass = shift; my $params = shift; + require WebGUI::SQL::Trace; + open my $trace_handle, '>:via(WebGUI::SQL::Trace)', $session; my (undef, $driver) = DBI->parse_dsn($dsn); - my $dbh = DBI->connect($dsn,$user,$pass,{RaiseError => 0, AutoCommit => 1, + my $dbh = DBI->connect($dsn, $user, $pass, { + RaiseError => 0, + AutoCommit => 1, $driver eq 'mysql' ? (mysql_enable_utf8 => 1) : (), }); + $dbh->trace('2|SQL', $trace_handle); unless (defined $dbh) { $session->errorHandler->error("Couldn't connect to database: $dsn : $DBI::errstr"); diff --git a/lib/WebGUI/SQL/ResultSet.pm b/lib/WebGUI/SQL/ResultSet.pm index ad0d25c46..4d64ccd9b 100644 --- a/lib/WebGUI/SQL/ResultSet.pm +++ b/lib/WebGUI/SQL/ResultSet.pm @@ -132,9 +132,7 @@ 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); + $self->sth->execute(@{ $placeholders }) or $self->session->errorHandler->fatal("Couldn't execute prepared statement: $sql : With place holders: ".join(", ", @{$placeholders}).". Root cause: ". $self->errorMessage); } diff --git a/lib/WebGUI/SQL/Trace.pm b/lib/WebGUI/SQL/Trace.pm new file mode 100644 index 000000000..efe382fdf --- /dev/null +++ b/lib/WebGUI/SQL/Trace.pm @@ -0,0 +1,55 @@ +package WebGUI::SQL::Trace; +use strict; +#use warnings; +use 5.008008; + +our $VERSION = '0.0.1'; + +sub PUSHED { + my ($class, $mode, $fh) = @_; + my $logger; + return bless \$logger, $class; +} + +sub OPEN { + my ($self, $session, $mode, $fh) = @_; + $$self = $session; + return 1; +} + +sub WRITE { + my ($self, $buf, $fh) = @_; + if ($buf =~ /\ABinding parameters: /) { + my $sql = $buf; + $sql =~ s/\ABinding parameters: //; + my $sub; + my $line; + for ( my $i = 0; caller($i); $i++) { + (my $package, undef, $line) = caller($i); + next + if $package eq 'WebGUI::SQL'; + next + if $package eq 'WebGUI::SQL::ResultSet'; + ($sub) = (caller($i + 1))[3]; + last; + } + $$self->log->debug("Query - $sub($line) : $sql"); + } + return length($buf); +} + +sub CLOSE { + my $self = shift; + return 0; +} + +1; + +__END__ + +=head1 NAME + +PerlIO::via::WebGUI - Log DBI output to WebGUI + +=cut + From 0bff8a0fa46410020a638ec7d1692429b1b85d6d Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 13 Apr 2010 19:25:42 -0500 Subject: [PATCH 48/92] WebGUI::SQL as DBI subclass --- lib/WebGUI/SQL.pm | 630 ++++++++++++++++-------------------- lib/WebGUI/SQL/ResultSet.pm | 374 ++++++++++----------- 2 files changed, 445 insertions(+), 559 deletions(-) diff --git a/lib/WebGUI/SQL.pm b/lib/WebGUI/SQL.pm index c3ed2cf2b..55d7490cf 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -15,11 +15,13 @@ 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 Try::Tiny; +use namespace::clean; =head1 NAME @@ -67,6 +69,93 @@ 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} = 1; + $params->{PrintError} = 0; + $params->{AutoCommit} = 1; + $params->{ShowErrorStatement} = 1; + $params->{HandleError} = sub { + $session->errorHandler->fatal(Carp::longmess(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; +our @ISA = qw(DBI::db); #------------------------------------------------------------------- @@ -77,8 +166,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 +193,6 @@ sub buildArray { return @{ $arrayRef }; } - #------------------------------------------------------------------- =head2 buildArrayRef ( sql, params ) @@ -122,16 +210,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 +249,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,24 +282,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"; - } - 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 @@ -246,13 +329,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; } @@ -282,18 +360,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; } #------------------------------------------------------------------- @@ -319,21 +400,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 ) @@ -364,7 +445,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 { @@ -383,77 +464,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; - - require WebGUI::SQL::Trace; - open my $trace_handle, '>:via(WebGUI::SQL::Trace)', $session; - 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) : (), - }); - $dbh->trace('2|SQL', $trace_handle); - - 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. @@ -461,8 +471,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; } @@ -487,43 +497,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 ( ) @@ -533,8 +512,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; } @@ -547,8 +526,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; } @@ -556,7 +535,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 @@ -565,14 +544,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; } #------------------------------------------------------------------- @@ -585,7 +563,7 @@ Returns the DBI driver used by this database link sub getDriver { my $self = shift; - return $self->{_dbh}->{Driver}->{Name}; + return $self->{Driver}->{Name}; } #------------------------------------------------------------------- @@ -609,30 +587,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 ) @@ -650,11 +616,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 }); } @@ -675,26 +640,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; } @@ -715,19 +679,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}; } #------------------------------------------------------------------- @@ -747,18 +703,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); } #------------------------------------------------------------------- @@ -778,15 +726,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; } @@ -807,39 +751,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; } #------------------------------------------------------------------- @@ -855,16 +778,29 @@ 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; } +#------------------------------------------------------------------- + +=head2 quoteIdentifier ( string ) + +Returns a string quoted as an identifier to be used as a table name, column name, etc. + +=head3 string + +Any scalar variable that needs to be escaped to be inserted into the database. + +=cut + +sub quoteIdentifier { + my $self = shift; + return $self->quote_identifier(@_); +} + #------------------------------------------------------------------- =head2 quoteIdentifier ( string ) @@ -901,31 +837,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 ( ) @@ -935,8 +854,14 @@ Returns a reference to the current session. =cut sub session { - my $self = shift; - return $self->{_session}; + my $self = shift; + if (@_) { + my $session = $self->{private_webgui_session} = shift; + require WebGUI::SQL::Trace; + open my $trace_handle, '>:via(WebGUI::SQL::Trace)', $session; + $self->trace('2|SQL', $trace_handle); + } + return $self->{private_webgui_session}; } @@ -965,22 +890,29 @@ 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) = @_; - $data->{$keyColumn} ||= $id; - if ($data->{$keyColumn} eq "new") { - $data->{$keyColumn} = $self->session->id->generate(); - } - my $dbh = $self->dbh; - my @fields = (); - my @data = (); - my @placeholders = (); - foreach my $key (keys %{$data}) { - push(@fields, $dbh->quote_identifier($key)); - push(@placeholders, '?'); - push(@data,$data->{$key}); - } - $self->write("replace into $table (" . join(",",@fields) . ") values (".join(",",@placeholders).")",\@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; + $self->do("REPLACE INTO $table ($key) VALUES (?)", {}, $id); + } + + my @fields = map { $self->quote_identifier($_) . '=?' } keys %$data; + my @data = values %$data; + + if (@fields) { + $self->do( + "UPDATE $table SET " . join(", ", @fields) + . " WHERE $key = ?", + {}, + @data, + $id, + ); + } + return $id; } @@ -1001,10 +933,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; } @@ -1026,11 +959,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 4d64ccd9b..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,160 +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}; - $self->sth->execute(@{ $placeholders }) or $self->session->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 ) @@ -215,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 ) @@ -245,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 ) @@ -303,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; From 2e419e63bed1e3ede8eb8c85fd0d6b570d7b916c Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Mon, 12 Apr 2010 07:39:46 -0500 Subject: [PATCH 49/92] skip more classes in DBI tracing --- lib/WebGUI/SQL/Trace.pm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/WebGUI/SQL/Trace.pm b/lib/WebGUI/SQL/Trace.pm index efe382fdf..8882abe80 100644 --- a/lib/WebGUI/SQL/Trace.pm +++ b/lib/WebGUI/SQL/Trace.pm @@ -27,9 +27,7 @@ sub WRITE { for ( my $i = 0; caller($i); $i++) { (my $package, undef, $line) = caller($i); next - if $package eq 'WebGUI::SQL'; - next - if $package eq 'WebGUI::SQL::ResultSet'; + if $package =~ /\A(?:WebGUI::SQL|DBI|DBD)(?:\z|::)/; ($sub) = (caller($i + 1))[3]; last; } From 18962e6bc9285bc3f8edecb56ba4f277a7e8651f Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 13 Apr 2010 15:42:59 -0500 Subject: [PATCH 50/92] better logging of sql --- lib/WebGUI/SQL/Trace.pm | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/lib/WebGUI/SQL/Trace.pm b/lib/WebGUI/SQL/Trace.pm index 8882abe80..e97d14366 100644 --- a/lib/WebGUI/SQL/Trace.pm +++ b/lib/WebGUI/SQL/Trace.pm @@ -22,16 +22,15 @@ sub WRITE { if ($buf =~ /\ABinding parameters: /) { my $sql = $buf; $sql =~ s/\ABinding parameters: //; - my $sub; - my $line; - for ( my $i = 0; caller($i); $i++) { - (my $package, undef, $line) = caller($i); - next - if $package =~ /\A(?:WebGUI::SQL|DBI|DBD)(?:\z|::)/; - ($sub) = (caller($i + 1))[3]; - last; + my $depth; + for ( $depth = 1; caller($depth); $depth++) { + my $package = caller($depth); + last + if $package !~ /\A(?:WebGUI::SQL|DBI|DBD)(?:\z|::)/; } - $$self->log->debug("Query - $sub($line) : $sql"); + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $depth + 1; + + $$self->log->debug("Query - $sql"); } return length($buf); } From 907a14831352edbc9a654f70664994d1cd232c5c Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 13 Apr 2010 19:56:25 -0500 Subject: [PATCH 51/92] remove webgui specific dbi tracing code, simplify errorhandler --- lib/WebGUI/SQL.pm | 5 +-- lib/WebGUI/SQL/Trace.pm | 52 ------------------------------ lib/WebGUI/Session/ErrorHandler.pm | 40 ++++++++++++----------- 3 files changed, 22 insertions(+), 75 deletions(-) delete mode 100644 lib/WebGUI/SQL/Trace.pm diff --git a/lib/WebGUI/SQL.pm b/lib/WebGUI/SQL.pm index 55d7490cf..de5c892f5 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -856,10 +856,7 @@ Returns a reference to the current session. sub session { my $self = shift; if (@_) { - my $session = $self->{private_webgui_session} = shift; - require WebGUI::SQL::Trace; - open my $trace_handle, '>:via(WebGUI::SQL::Trace)', $session; - $self->trace('2|SQL', $trace_handle); + $self->{private_webgui_session} = shift; } return $self->{private_webgui_session}; } diff --git a/lib/WebGUI/SQL/Trace.pm b/lib/WebGUI/SQL/Trace.pm deleted file mode 100644 index e97d14366..000000000 --- a/lib/WebGUI/SQL/Trace.pm +++ /dev/null @@ -1,52 +0,0 @@ -package WebGUI::SQL::Trace; -use strict; -#use warnings; -use 5.008008; - -our $VERSION = '0.0.1'; - -sub PUSHED { - my ($class, $mode, $fh) = @_; - my $logger; - return bless \$logger, $class; -} - -sub OPEN { - my ($self, $session, $mode, $fh) = @_; - $$self = $session; - 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); - last - if $package !~ /\A(?:WebGUI::SQL|DBI|DBD)(?:\z|::)/; - } - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $depth + 1; - - $$self->log->debug("Query - $sql"); - } - return length($buf); -} - -sub CLOSE { - my $self = shift; - return 0; -} - -1; - -__END__ - -=head1 NAME - -PerlIO::via::WebGUI - Log DBI output to WebGUI - -=cut - diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 9c4e24421..96f6a4dd6 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -203,8 +203,8 @@ The message to use. sub fatal { my $self = shift; my $message = shift; - @_ = ({ level => 'fatal', message => $message}); - goto $self->getLogger; + Sub::Uplevel::uplevel( 1, $self->getLogger, { level => 'fatal', message => $message}); + WebGUI::Error::Fatal->throw( error => $message ); } @@ -216,7 +216,25 @@ Returns a reference to the logger. =cut -sub getLogger { $_[0]->{_logger} } +sub getLogger { + my $self = shift; + if (my $req = $self->session->request) { + my $logger = $req->logger; + return $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) + Log::Log4perl->init_once( $self->session->config->getWebguiRoot . "/etc/log.conf" ); + my $log4perl = Log::Log4perl->get_logger( $self->session->config->getFilename ); + sub { + my $args = shift; + my $level = $args->{level}; + $log4perl->$level( $args->{message} ); + }; +} #------------------------------------------------------------------- @@ -276,21 +294,6 @@ sub new { my $session = shift; 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}; - $log4perl->$level( $args->{message} ); - }; - } - bless { _session => $session, _logger => $logger }, $class; } @@ -364,6 +367,5 @@ sub warn { goto $self->getLogger; } - 1; From 30b7e4bdb3136e3bf0c8c276e1227c464397d6a1 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 13 Apr 2010 20:43:00 -0500 Subject: [PATCH 52/92] clean up debug logger --- lib/Plack/Middleware/Debug/Logger.pm | 29 +++---- lib/WebGUI/Middleware/Session.pm | 23 +++++- lib/WebGUI/Session/ErrorHandler.pm | 112 ++++----------------------- 3 files changed, 47 insertions(+), 117 deletions(-) diff --git a/lib/Plack/Middleware/Debug/Logger.pm b/lib/Plack/Middleware/Debug/Logger.pm index d1fea0017..4cd3efe2e 100644 --- a/lib/Plack/Middleware/Debug/Logger.pm +++ b/lib/Plack/Middleware/Debug/Logger.pm @@ -3,41 +3,34 @@ use 5.008; use strict; use warnings; use parent qw(Plack::Middleware::Debug::Base); -use Sub::Uplevel (); our $VERSION = '0.07'; sub run { my ($self, $env, $panel) = @_; - my $wrap_logger = $env->{'psgix.logger'}; - my %output; + 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}; - $message =~ s/\n\s*/\n /msxg; - $message =~ s/\n?\z/\n/msx; - $output{lc $args->{level}} ||= ''; - $output{lc $args->{level}} .= $caller . $message; - if ($wrap_logger) { - Sub::Uplevel::uplevel 1, $wrap_logger, @_; + push @$log_output, $args->{level} => $caller . $message; + if ($logger) { + goto $logger; } }; return sub { my $res = shift; - if ($wrap_logger) { - $env->{'psgix.logger'} = $wrap_logger; + if ($logger) { + $env->{'psgix.logger'} = $logger; } - my $content = ''; - for my $level ( qw(info debug warn error fatal) ) { - if ($output{$level}) { - $content .= "

\u$level

"; - $content .= '
' . $self->render_lines($output{$level}) . '
'; - } + $panel->nav_subtitle(scalar @$log_output / 2 . ' messages'); + if (@$log_output) { + $panel->content('
' . $self->render_list_pairs( $log_output ) . '
'); } - $panel->content($content); }; } diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 2165e14b4..b05c28d00 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -3,6 +3,7 @@ use strict; use parent qw(Plack::Middleware); use WebGUI::Config; use WebGUI::Session; +use WebGUI::Utility (); use Try::Tiny; use Plack::Middleware::StackTrace; use Plack::Middleware::Debug; @@ -37,7 +38,7 @@ sub call { weaken $self->{config}; my $config = $self->config or die 'Mandatory config parameter missing'; - + # Logger fallback if (!$env->{'psgix.logger'}) { $app = Plack::Middleware::SimpleLogger->wrap( $app ); @@ -66,7 +67,7 @@ sub call { # Perhaps I'm being paranoid.. weaken $session->{_config}; - my $debug = $session->log->canShowDebug; + my $debug = $self->canShowDebug($env); if ($debug) { $app = Plack::Middleware::StackTrace->wrap($app); $app = Plack::Middleware::Debug->wrap( $app, @@ -112,4 +113,22 @@ sub call { ); } +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/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 96f6a4dd6..8fa2f454d 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -76,64 +76,6 @@ sub audit { goto $self->can('info'); } - -#------------------------------------------------------------------- - -=head2 canShowBasedOnIP ( $ipSetting ) - -Returns true if the the user's IP address matches the requested IP setting. - -=head3 ipSetting - -The setting to pull from the database. It should containt a CSV list of IP -addresses in CIDR format. - -=cut - -sub canShowBasedOnIP { - my $self = shift; - my $ipSetting = shift; - return 0 unless $ipSetting; - return 1 if ($self->session->setting->get($ipSetting) eq ""); - my $ips = $self->session->setting->get($ipSetting); - $ips =~ s/\s+//g; - my @ips = split(",", $ips); - my $ok = WebGUI::Utility::isInSubnet($self->session->env->getIp, [ @ips] ); - return $ok; -} - -#------------------------------------------------------------------- - -=head2 canShowDebug ( ) - -Returns true if the user meets the condition to see debugging information and debug mode is enabled. -This method caches its value, so long processes may need to manually clear the cached in $self->{_canShowDebug}. - -=cut - -sub canShowDebug { - my $self = shift; - - # if we have a cached false value, we can use it - # true values need additional checks - if (exists $self->{_canShowDebug} && !$self->{_canShowDebug}) { - return 0; - } - - ##This check prevents in infinite loop during startup. - return 0 unless ($self->session->hasSettings); - - # Allow programmers to stop debugging output for certain requests - return 0 if $self->{_preventDebugOutput}; - - my $canShow = $self->session->setting->get("showDebug") - && $self->canShowBasedOnIP('debugIp'); - $self->{_canShowDebug} = $canShow; - - return $canShow - && substr($self->session->http->getMimeType(),0,9) eq "text/html"; -} - #------------------------------------------------------------------- =head2 canShowPerformanceIndicators ( ) @@ -217,47 +159,9 @@ Returns a reference to the logger. =cut sub getLogger { - my $self = shift; - if (my $req = $self->session->request) { - my $logger = $req->logger; - return $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) - Log::Log4perl->init_once( $self->session->config->getWebguiRoot . "/etc/log.conf" ); - my $log4perl = Log::Log4perl->get_logger( $self->session->config->getFilename ); - sub { - my $args = shift; - my $level = $args->{level}; - $log4perl->$level( $args->{message} ); - }; + $_[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 ) @@ -294,6 +198,20 @@ sub new { my $session = shift; 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) + Log::Log4perl->init_once( $session->config->getWebguiRoot . "/etc/log.conf" ); + my $log4perl = Log::Log4perl->get_logger( $session->config->getFilename ); + $logger = sub { + my $args = shift; + my $level = $args->{level}; + $log4perl->$level( $args->{message} ); + }; + } + bless { _session => $session, _logger => $logger }, $class; } From 30fc3fab104e8ee9d1d4f8d20b6a69ea9a6584de Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 13 Apr 2010 21:14:14 -0500 Subject: [PATCH 53/92] fix log->audit and log->security --- lib/WebGUI/Session/ErrorHandler.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 8fa2f454d..0cbb41093 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -72,7 +72,7 @@ Whatever message you wish to insert into the log. sub audit { my $self = shift; my $message = shift; - @_ = ($self->session->user->username." (".$self->session->user->userId.") ".$message); + @_ = ($self, $self->session->user->username." (".$self->session->user->userId.") ".$message); goto $self->can('info'); } @@ -246,7 +246,7 @@ The message you wish to add to the log. sub security { my $self = shift; my $message = shift; - @_ = ($self->session->user->username." (".$self->session->user->userId.") connecting from " + @_ = ($self, $self->session->user->username." (".$self->session->user->userId.") connecting from " .$self->session->env->getIp." attempted to ".$message); goto $self->can('warn'); } From f2ce1eff857c498de8feaadc3b2e373cea9fa760 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Wed, 14 Apr 2010 14:51:52 -0500 Subject: [PATCH 54/92] convert performance indicators to a Plack::Middleware::Debug panel --- lib/WebGUI/Asset/Wobject/Dashboard.pm | 1 - lib/WebGUI/Asset/Wobject/Layout.pm | 7 +- lib/WebGUI/Content/Asset.pm | 23 +------ lib/WebGUI/Macro/AssetProxy.pm | 7 +- lib/WebGUI/Middleware/Debug/Performance.pm | 77 ++++++++++++++++++++++ lib/WebGUI/Middleware/Session.pm | 2 + lib/WebGUI/Session/ErrorHandler.pm | 12 ++-- 7 files changed, 98 insertions(+), 31 deletions(-) create mode 100644 lib/WebGUI/Middleware/Debug/Performance.pm diff --git a/lib/WebGUI/Asset/Wobject/Dashboard.pm b/lib/WebGUI/Asset/Wobject/Dashboard.pm index aa8113a49..4c3f09d3c 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/Layout.pm b/lib/WebGUI/Asset/Wobject/Layout.pm index 2e26e8710..6ee065de9 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/Content/Asset.pm b/lib/WebGUI/Content/Asset.pm index 425d4f2db..616000ea6 100644 --- a/lib/WebGUI/Content/Asset.pm +++ b/lib/WebGUI/Content/Asset.pm @@ -83,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)); 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/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/Session.pm b/lib/WebGUI/Middleware/Session.pm index b05c28d00..76444a5e5 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -7,6 +7,7 @@ use WebGUI::Utility (); use Try::Tiny; use Plack::Middleware::StackTrace; use Plack::Middleware::Debug; +use WebGUI::Middleware::Debug::Performance; use WebGUI::Middleware::HTTPExceptions; use Plack::Middleware::ErrorDocument; use Plack::Middleware::SimpleLogger; @@ -81,6 +82,7 @@ sub call { [ 'MySQLTrace', skip_packages => qr/\AWebGUI::SQL(?:\z|::)/ ], 'Response', 'Logger', + sub { WebGUI::Middleware::Debug::Performance->wrap($_[0]) }, ], ); } diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 0cbb41093..1f0796785 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -21,6 +21,7 @@ use JSON; use HTML::Entities qw(encode_entities); use Log::Log4perl; use WebGUI::Exception; +use Sub::Uplevel; =head1 NAME @@ -84,10 +85,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; } From 8c3ecce95f0b1da2a13c51d19de4cdaf41fec292 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 07:27:25 -0500 Subject: [PATCH 55/92] remove redundant logger --- lib/Plack/Middleware/Debug/WgLogger.pm | 31 -------------------------- 1 file changed, 31 deletions(-) delete mode 100644 lib/Plack/Middleware/Debug/WgLogger.pm diff --git a/lib/Plack/Middleware/Debug/WgLogger.pm b/lib/Plack/Middleware/Debug/WgLogger.pm deleted file mode 100644 index 94d0e2d51..000000000 --- a/lib/Plack/Middleware/Debug/WgLogger.pm +++ /dev/null @@ -1,31 +0,0 @@ -package Plack::Middleware::Debug::WgLogger; -use strict; -use parent qw(Plack::Middleware::Debug::Base); -our $VERSION = '0.07'; - -# This will be moved to the WebGUI::Middleware::Debug::WgLogger namespace -# once Plack::Middleware::Debug supports that - -sub run { - my ($self, $env, $panel) = @_; - - my $logger = $env->{'psgix.logger'}; - - my $log_output = []; - $env->{'psgix.logger'} = sub { - my $args = shift; - push @$log_output, $args->{level} => $args->{message}; - $logger && $logger->($args); - }; - delete $env->{'webgui.session'}->{_errorHandler}; - - return sub { - my $res = shift; - $panel->nav_subtitle(scalar @$log_output . " messages"); - $panel->content($self->render_list_pairs($log_output)); - }; -} - -sub panel_name { 'WebGUI Log' } - -1; \ No newline at end of file From cd9afc78b9d62277a6ad6533b72cf11d240c2da3 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 08:37:12 -0500 Subject: [PATCH 56/92] fix some WebGUI::Paths stuff, multi-site plackup --- app.psgi | 79 ++++++++------------------------ lib/WebGUI.pm | 12 +---- lib/WebGUI/Middleware/Session.pm | 4 +- lib/WebGUI/Paths.pm | 7 +-- var/site.psgi | 34 ++++++++++++++ 5 files changed, 60 insertions(+), 76 deletions(-) create mode 100644 var/site.psgi diff --git a/app.psgi b/app.psgi index dc644af78..b18377b1b 100644 --- a/app.psgi +++ b/app.psgi @@ -1,66 +1,25 @@ use strict; use Plack::Builder; -use lib '/data/WebGUI/lib'; -use WebGUI; +use WebGUI::Paths -inc; +use WebGUI::Config; +use File::Spec; -my $root = '/data/WebGUI'; +my $standard_psgi = File::Spec->catfile(WebGUI::Paths->var, 'site.psgi'); builder { - mount "http://dev.localhost.localdomain/" => builder { - - my $wg = WebGUI->new( root => $root, site => 'dev.localhost.localdomain.conf' ); - my $config = $wg->config; - enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; - - # Reproduce URL handler functionality with middleware - enable '+WebGUI::Middleware::Snoop'; - enable 'Static', root => $root, path => sub {s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt}}; - 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{^$extrasURL/}{}}; - - # Open/close the WebGUI::Session at the outer-most onion layer - enable '+WebGUI::Middleware::Session', - config => $config, - error_docs => { 500 => "$root/www/maintenance.html" }; - - # This one uses the Session object, so it comes after WebGUI::Middleware::Session - enable '+WebGUI::Middleware::WGAccess', config => $config; - - # Return the app - $wg->psgi_app; - }; - - mount "http://dev2.localhost.localdomain/" => builder { - - my $wg = WebGUI->new( root => $root, site => 'dev2.localhost.localdomain.conf' ); - my $config = $wg->config; - enable 'Log4perl', category => 'mysite', conf => "$root/etc/log.conf"; - - # Reproduce URL handler functionality with middleware - enable '+WebGUI::Middleware::Snoop'; - enable 'Static', root => $root, path => sub {s{^/\*give-credit-where-credit-is-due\*$}{docs/credits.txt}}; - 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{^$extrasURL/}{}}; - - # Open/close the WebGUI::Session at the outer-most onion layer - enable '+WebGUI::Middleware::Session', - config => $config, - error_docs => { 500 => "$root/www/maintenance.html" }; - - # This one uses the Session object, so it comes after WebGUI::Middleware::Session - enable '+WebGUI::Middleware::WGAccess', config => $config; - - # Return the app - $wg->psgi_app; - }; + my $first_app; + for my $config_file (WebGUI::Paths->siteConfigs) { + my $config = WebGUI::Config->new($config_file); + my $psgi = $config->get('psgiFile') || $standard_psgi; + my $app = do { + $ENV{WEBGUI_CONFIG} = $config_file; + Plack::Util::load_psgi($psgi); + }; + $first_app ||= $app; + for my $sitename ( @{ $config->get('sitename') } ) { + mount "http://$sitename/" => $app; + } + } + mount '/' => $first_app; }; + diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 742f342f9..88ead5ff6 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -48,7 +48,6 @@ These subroutines are available from this package: =cut -has root => ( is => 'ro', isa => 'Str', default => '/data/WebGUI' ); has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); has config => ( is => 'rw', isa => 'WebGUI::Config' ); @@ -75,7 +74,7 @@ sub BUILD { $self->config($config); } -sub psgi_app { +sub to_app { my $self = shift; return $self->{psgi_app} ||= $self->compile_psgi_app; } @@ -83,10 +82,6 @@ sub psgi_app { sub compile_psgi_app { my $self = shift; - # Preload all modules in the master (parent) thread before the Server does any - # child forking. This should save a lot of memory in copy-on-write friendly environments. - $self->preload; - # WebGUI is a PSGI app is a Perl code reference. Let's create one. # Each web request results in a call to this sub return sub { @@ -143,11 +138,6 @@ sub compile_psgi_app { }; } - -sub preload { - WebGUI::Paths->preloadAll; -} - sub handle { my ( $session ) = @_; diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 76444a5e5..15fbecd25 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -37,7 +37,7 @@ sub call { my $app = $self->app; weaken $self->{config}; - + my $config = $self->config or die 'Mandatory config parameter missing'; # Logger fallback @@ -46,7 +46,7 @@ sub call { } my $session = try { - $env->{'webgui.session'} = WebGUI::Session->open( $config->getWebguiRoot, $config, $env ); + $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 - $_"; diff --git a/lib/WebGUI/Paths.pm b/lib/WebGUI/Paths.pm index eeac57101..ef2dfc446 100644 --- a/lib/WebGUI/Paths.pm +++ b/lib/WebGUI/Paths.pm @@ -201,7 +201,7 @@ Returns the list of modules to exclude from preloading as an array. sub preloadExclude { my $class = shift; - my @excludes = _readTextLines($class->preloadExclude); + my @excludes = _readTextLines($class->preloadExclusions); return @excludes; } @@ -217,8 +217,9 @@ sub preloadAll { require WebGUI::Pluggable; + my @exclusions = $class->preloadExclude; WebGUI::Pluggable::findAndLoad( 'WebGUI', { - exclude => \( $class->preloadExclude ), + exclude => \@exclusions, onLoadFail => sub { warn sprintf "Error loading %s: %s\n", @_ }, }); } @@ -226,7 +227,7 @@ sub preloadAll { sub _readTextLines { my $file = shift; my @lines; - open my $fh, '<', $file or croak "Cannot open $file: $!"; + open my $fh, '<', $file or return; while (my $line = <$fh>) { $line =~ s/#.*//; $line =~ s/^\s+//; diff --git a/var/site.psgi b/var/site.psgi new file mode 100644 index 000000000..b899357a5 --- /dev/null +++ b/var/site.psgi @@ -0,0 +1,34 @@ +use strict; +use Plack::Builder; +use WebGUI; +use WebGUI::Paths; + +my $config = $ENV{WEBGUI_CONFIG}; +builder { + my $wg = WebGUI->new( site => $ENV{WEBGUI_CONFIG} ); + my $config = $wg->config; + + enable 'Log4perl', category => $config->getFilename, conf => WebGUI::Paths->logConfig; + + # 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{^$extrasURL/}{}}; + + # Open/close the WebGUI::Session at the outer-most onion layer + enable '+WebGUI::Middleware::Session', + config => $config, + error_docs => { 500 => $config->get('maintenancePage') }; + + # This one uses the Session object, so it comes after WebGUI::Middleware::Session + enable '+WebGUI::Middleware::WGAccess', config => $config; + + # Return the app + $wg->to_app; +}; + From e4a0017ce9d93d1149b434da4869fb7a9bed746b Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 09:06:40 -0500 Subject: [PATCH 57/92] move debug configuration into psgi --- lib/WebGUI/Middleware/Session.pm | 21 ++------------------- var/site.psgi | 14 ++++++++++++++ 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 15fbecd25..175790c6f 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -64,28 +64,11 @@ sub call { return [ 500, [ 'Content-Type' => 'text/plain' ], [ 'Internal Server Error' ] ]; } } - + # Perhaps I'm being paranoid.. weaken $session->{_config}; - my $debug = $self->canShowDebug($env); - if ($debug) { - $app = Plack::Middleware::StackTrace->wrap($app); - $app = Plack::Middleware::Debug->wrap( $app, - panels => [ - 'Environment', - 'Response', - 'Timer', - 'Memory', - 'Session', - 'PerlConfig', - [ 'MySQLTrace', skip_packages => qr/\AWebGUI::SQL(?:\z|::)/ ], - 'Response', - 'Logger', - sub { WebGUI::Middleware::Debug::Performance->wrap($_[0]) }, - ], - ); - } + my $debug = $env->{'webgui.debug'} = $self->canShowDebug($env); # Turn exceptions into HTTP errors $app = WebGUI::Middleware::HTTPExceptions->wrap($app); diff --git a/var/site.psgi b/var/site.psgi index b899357a5..83d6d97db 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -25,6 +25,20 @@ builder { config => $config, error_docs => { 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', + sub { WebGUI::Middleware::Debug::Performance->wrap($_[0]) }, + ]; + # This one uses the Session object, so it comes after WebGUI::Middleware::Session enable '+WebGUI::Middleware::WGAccess', config => $config; From 241c94175f8fc1053c372ad8b11081a167b52625 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 18:08:16 -0500 Subject: [PATCH 58/92] move more stuff into psgi file, rewrite WGAccess middleware --- lib/WebGUI/Middleware/Session.pm | 31 ++--------- lib/WebGUI/Middleware/WGAccess.pm | 91 ++++++++++++++++--------------- var/site.psgi | 18 ++++-- 3 files changed, 63 insertions(+), 77 deletions(-) diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 175790c6f..3d4f4e303 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -5,15 +5,9 @@ use WebGUI::Config; use WebGUI::Session; use WebGUI::Utility (); use Try::Tiny; -use Plack::Middleware::StackTrace; -use Plack::Middleware::Debug; -use WebGUI::Middleware::Debug::Performance; use WebGUI::Middleware::HTTPExceptions; -use Plack::Middleware::ErrorDocument; use Plack::Middleware::SimpleLogger; -use Scalar::Util qw(weaken); - -use Plack::Util::Accessor qw( config error_docs ); +use Plack::Util::Accessor qw( config ); =head1 NAME @@ -30,13 +24,14 @@ the session out of the PSGI env hash: and not worry about closing it. +It also sets C as appropriate. + =cut sub call { my ( $self, $env ) = @_; my $app = $self->app; - weaken $self->{config}; my $config = $self->config or die 'Mandatory config parameter missing'; @@ -57,27 +52,11 @@ sub call { # 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 - # (using the error_docs mapping) - if ($self->error_docs) { - return Plack::Middleware::ErrorDocument->wrap( sub { [ 500, [], [] ] }, %{ $self->error_docs } )->($env); - } else { - return [ 500, [ 'Content-Type' => 'text/plain' ], [ 'Internal Server Error' ] ]; - } + return [ 500, [ 'Content-Type' => 'text/plain' ], [ 'Internal Server Error' ] ]; } - # Perhaps I'm being paranoid.. - weaken $session->{_config}; - my $debug = $env->{'webgui.debug'} = $self->canShowDebug($env); - # Turn exceptions into HTTP errors - $app = WebGUI::Middleware::HTTPExceptions->wrap($app); - - # HTTP error document mapping - if ( !$debug && $self->error_docs ) { - $app = Plack::Middleware::ErrorDocument->wrap( $app, %{ $self->error_docs } ); - } - # Run the app my $res = $app->($env); @@ -91,7 +70,7 @@ sub call { $env->{'webgui.session'}->close(); #memory_cycle_ok( $env->{'webgui.session'} ); delete $env->{'webgui.session'}; - + #use Test::Memory::Cycle; #memory_cycle_ok( $env ); } diff --git a/lib/WebGUI/Middleware/WGAccess.pm b/lib/WebGUI/Middleware/WGAccess.pm index ba5d3d179..74e23c169 100644 --- a/lib/WebGUI/Middleware/WGAccess.pm +++ b/lib/WebGUI/Middleware/WGAccess.pm @@ -1,8 +1,9 @@ package WebGUI::Middleware::WGAccess; use strict; -use Plack::App::File; use parent qw(Plack::Middleware); -use Path::Class 'dir'; +use Path::Class::File; +use Scalar::Util; +use JSON (); =head1 NAME @@ -18,52 +19,52 @@ to be serving static files with something a lot faster. =cut -use Plack::Util::Accessor qw( config ); - sub call { my $self = shift; my $env = shift; - my $app = $self->app; - my $config = $self->config or die 'Mandatory config parameter missing'; - my $uploadsPath = $config->get('uploadsPath'); - my $uploadsURL = $config->get('uploadsURL'); - - my $path = $env->{PATH_INFO}; - my $matched = $path =~ s{^\Q$uploadsURL\E/}{}; - return $app->($env) unless $matched; - - my $root = dir($uploadsPath); - my $file = $root->file(File::Spec::Unix->splitpath($path)); - my $wgaccess = File::Spec::Unix->catfile($file->dir, '.wgaccess'); - - if (-e $wgaccess) { - my $fileContents; - open(my $FILE, "<", $wgaccess); - while (my $line = <$FILE>) { - $fileContents .= $line; - } - close($FILE); - my @privs = split("\n", $fileContents); - - unless ($privs[1] eq "7" || $privs[1] eq "1") { - my $session = $env->{'webgui.session'}; - my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); - warn "has: $hasPrivs"; - warn $session->var->get("userId"); - warn $session->user->isInGroup($privs[1]); - warn $session->user->isInGroup($privs[2]); - if ($hasPrivs) { - $self->{file} ||= Plack::App::File->new; - return $self->{file}->serve_path($env, $file); # serve statically - } - else { - return [403, ['Content-Type' => 'text/plain'], ['Forbidden']]; - } - } + 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']; } - - $self->{file} ||= Plack::App::File->new; - return $self->{file}->serve_path($env, $file); # serve statically + + 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; \ No newline at end of file +1; diff --git a/var/site.psgi b/var/site.psgi index 83d6d97db..2db3bdf59 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -1,7 +1,9 @@ use strict; use Plack::Builder; +use Plack::App::File; use WebGUI; use WebGUI::Paths; +use WebGUI::Middleware::Debug::Performance; my $config = $ENV{WEBGUI_CONFIG}; builder { @@ -18,13 +20,14 @@ builder { # 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{^$extrasURL/}{}}; + 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, - error_docs => { 500 => $config->get('maintenancePage') }; + 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', @@ -40,9 +43,12 @@ builder { ]; # This one uses the Session object, so it comes after WebGUI::Middleware::Session - enable '+WebGUI::Middleware::WGAccess', config => $config; + mount $config->get('uploadsURL') => builder { + enable '+WebGUI::Middleware::WGAccess'; + Plack::App::File->new(root => $config->get('uploadsPath'))->to_app; + }; # Return the app - $wg->to_app; + mount '/' => $wg->to_app; }; From 2b78fe913b8a4e837de11611cbb5b5cbe983de50 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 19:29:18 -0500 Subject: [PATCH 59/92] classes under session should weaken their session references --- lib/WebGUI/Session.pm | 2 +- lib/WebGUI/Session/DateTime.pm | 20 +++--------- lib/WebGUI/Session/Env.pm | 49 +++++++++++------------------- lib/WebGUI/Session/ErrorHandler.pm | 12 ++++---- lib/WebGUI/Session/Form.pm | 1 - lib/WebGUI/Session/Http.pm | 31 ++++++------------- lib/WebGUI/Session/Icon.pm | 19 +++--------- lib/WebGUI/Session/Id.pm | 22 ++++---------- lib/WebGUI/Session/Os.pm | 16 ---------- lib/WebGUI/Session/Output.pm | 19 +++--------- lib/WebGUI/Session/Privilege.pm | 20 +++--------- lib/WebGUI/Session/Scratch.pm | 21 +++---------- lib/WebGUI/Session/Setting.pm | 22 +++----------- lib/WebGUI/Session/Stow.pm | 19 +++--------- lib/WebGUI/Session/Style.pm | 19 +++--------- lib/WebGUI/Session/Url.pm | 19 +++--------- lib/WebGUI/Session/Var.pm | 18 ++--------- 17 files changed, 81 insertions(+), 248 deletions(-) diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 662ce0743..3ceca9acf 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -294,7 +294,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}; } diff --git a/lib/WebGUI/Session/DateTime.pm b/lib/WebGUI/Session/DateTime.pm index a07f4f832..cac8c12ff 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); +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 1f0796785..19c0d5a4a 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -17,13 +17,11 @@ package WebGUI::Session::ErrorHandler; use strict; use WebGUI::Paths; -use JSON; -use HTML::Entities qw(encode_entities); -use Log::Log4perl; use WebGUI::Exception; use Sub::Uplevel; +use Scalar::Util qw(weaken); -=head1 NAME +=head1 NAME Package WebGUI::Session::ErrorHandler @@ -201,6 +199,8 @@ sub new { my $class = shift; my $session = shift; + my $self = bless { _session => $session }, $class; + weaken $self->{_session}; my $logger = $session->request && $session->request->logger; if ( !$logger ) { @@ -215,8 +215,8 @@ sub new { $log4perl->$level( $args->{message} ); }; } - - bless { _session => $session, _logger => $logger }, $class; + $self->{_logger} = $logger; + return $self; } #---------------------------------------------------------------------------- diff --git a/lib/WebGUI/Session/Form.pm b/lib/WebGUI/Session/Form.pm index 71902060e..42f252072 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'; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 30e753937..8f09c08fe 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -16,7 +16,8 @@ package WebGUI::Session::Http; use strict; -use WebGUI::Utility; +use Scalar::Util qw(weaken); +use HTTP::Date (); sub _deprecated { my $alt = shift; @@ -59,21 +60,6 @@ These methods are available from this package: =cut -#------------------------------------------------------------------- - -=head2 DESTROY ( ) - -Deconstructor. - -=cut - -sub DESTROY { - my $self = shift; - undef $self; -} - - - #------------------------------------------------------------------- =head2 getCacheControl ( ) @@ -222,10 +208,9 @@ sub ifModifiedSince { my $self = shift; my $epoch = shift; my $maxCacheTimeout = shift; - require APR::Date; 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. @@ -265,7 +250,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; } @@ -282,7 +269,7 @@ sub sendHeader { return undef if ($self->{_http}{noHeader}); return $self->_sendMinimalHeader unless defined $self->session->db(1); - my ($request, $response, $datetime, $config, $var) = $self->session->quick(qw(request response 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"); @@ -298,7 +285,7 @@ sub sendHeader { } else { $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")) { $response->header("Cache-Control" => "private, max-age=1"); @@ -315,7 +302,7 @@ sub sendHeader { } # 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); + my $date = HTTP::Date::time2str(time() + $cacheControl); $response->header( 'Expires' => $date ); } } 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 index 0ef85f30a..80ebd7c10 100644 --- a/lib/WebGUI/Session/Os.pm +++ b/lib/WebGUI/Session/Os.pm @@ -36,22 +36,6 @@ These methods are available from this package: =cut - -#------------------------------------------------------------------- - -=head2 DESTROY ( ) - -Deconstructor. - -=cut - -sub DESTROY { - my $self = shift; - undef $self; -} - - - #------------------------------------------------------------------- =head2 get( varName ) diff --git a/lib/WebGUI/Session/Output.pm b/lib/WebGUI/Session/Output.pm index c148dc62c..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; } #------------------------------------------------------------------- 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/Scratch.pm b/lib/WebGUI/Session/Scratch.pm index d6195b7ef..9fb026501 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 = eval{$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 47e96348a..7de9755dd 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 ) @@ -431,7 +418,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 3641ae66f..1cc922af9 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); } From 512251865275b441f6fde0706ef9277c72a9217f Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 19:30:07 -0500 Subject: [PATCH 60/92] remove useless DESTROYs --- lib/Spectre/Cron.pm | 1 - lib/Spectre/Workflow.pm | 1 - lib/WebGUI/AdSpace.pm | 13 ----------- lib/WebGUI/AdSpace/Ad.pm | 13 ----------- lib/WebGUI/Asset/Wobject/HttpProxy.pm | 2 +- lib/WebGUI/Asset/Wobject/HttpProxy/Parse.pm | 5 ----- lib/WebGUI/DatabaseLink.pm | 1 - lib/WebGUI/FormValidator.pm | 24 ++++++--------------- lib/WebGUI/Group.pm | 16 -------------- lib/WebGUI/HTMLForm.pm | 14 ------------ lib/WebGUI/Inbox.pm | 13 ----------- lib/WebGUI/Inbox/Message.pm | 13 ----------- lib/WebGUI/LDAPLink.pm | 2 +- lib/WebGUI/Search/Index.pm | 13 ----------- lib/WebGUI/Shop/Address.pm | 1 - lib/WebGUI/Shop/AddressBook.pm | 1 - lib/WebGUI/Shop/Transaction.pm | 1 - lib/WebGUI/Shop/TransactionItem.pm | 1 - lib/WebGUI/Workflow.pm | 15 ------------- lib/WebGUI/Workflow/Activity.pm | 15 ------------- lib/WebGUI/Workflow/Cron.pm | 15 ------------- lib/WebGUI/Workflow/Instance.pm | 2 -- lib/WebGUI/Workflow/Spectre.pm | 13 ----------- 23 files changed, 8 insertions(+), 187 deletions(-) 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/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/Wobject/HttpProxy.pm b/lib/WebGUI/Asset/Wobject/HttpProxy.pm index 299b9048d..901bcef2f 100644 --- a/lib/WebGUI/Asset/Wobject/HttpProxy.pm +++ b/lib/WebGUI/Asset/Wobject/HttpProxy.pm @@ -442,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/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/FormValidator.pm b/lib/WebGUI/FormValidator.pm index 6c465c382..bb1cada6b 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,21 +80,6 @@ sub AUTOLOAD { return $control->getValue(@args); } -#------------------------------------------------------------------- - -=head2 DESTROY ( ) - -Deconstructor. - -=cut - -sub DESTROY { - my $self = shift; - undef $self; -} - - - #------------------------------------------------------------------- =head2 get ( ) @@ -120,9 +106,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 97ceb3c7f..21bba12e5 100644 --- a/lib/WebGUI/Group.pm +++ b/lib/WebGUI/Group.pm @@ -270,7 +270,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; } #------------------------------------------------------------------- @@ -363,21 +362,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/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/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 7619dbc51..31190b8c0 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 60c2a37c8..4e52b29a0 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/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/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. From ff2a36026a4f28be3f36152b879e06820c1b3e58 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 19:30:39 -0500 Subject: [PATCH 61/92] WebGUI.pm as subclass of Plack::Component --- lib/WebGUI.pm | 154 ++++++++++++++++++++++---------------------------- var/site.psgi | 4 +- 2 files changed, 70 insertions(+), 88 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 88ead5ff6..613b5ccc4 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -20,16 +20,17 @@ our $STATUS = 'beta'; =cut use strict; -use MIME::Base64 (); +use Moose; +use MooseX::NonMoose; + use WebGUI::Config; use WebGUI::Pluggable; -use WebGUI::Session; -use WebGUI::User; -use WebGUI::Session::Request; use WebGUI::Paths; -use Moose; + use Try::Tiny; +extends 'Plack::Component'; + =head1 NAME Package WebGUI @@ -48,92 +49,73 @@ These subroutines are available from this package: =cut -has site => ( is => 'ro', isa => 'Str', default => 'dev.localhost.localdomain.conf' ); -has config => ( is => 'rw', isa => 'WebGUI::Config' ); +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); + }, +); -around BUILDARGS => sub { - my $orig = shift; - my $class = shift; - - # Make constructor work as: - # WebGUI->new( $site ) - # In addition to the more verbose: - # WebGUI->new( root => $root, site => $site ) - if (@_ eq 1) { - return $class->$orig(site => $_[0] ); - } else { - return $class->$orig(@_); - } -}; - -sub BUILD { +# Each web request results in a call to this sub +sub call { my $self = shift; + my $env = shift; - # Instantiate the WebGUI::Config object - my $config = WebGUI::Config->new( $self->site ); - $self->config($config); -} - -sub to_app { - my $self = shift; - return $self->{psgi_app} ||= $self->compile_psgi_app; -} - -sub compile_psgi_app { - my $self = shift; - - # WebGUI is a PSGI app is a Perl code reference. Let's create one. - # Each web request results in a call to this sub + # 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 $env = shift; - - # 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'; - - # Handle the request - handle($session); - - # Construct the PSGI response - my $response = $session->response; - my $psgi_response = $response->finalize; - - # 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] ] ); - - # Store the writer object in the WebGUI::Session::Response object - $response->writer($writer); - - # Now call the callback that does the streaming - $response->streamer->($session); - - # 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); + my $responder = shift; + my $session = $env->{'webgui.session'} + or die 'Missing WebGUI Session - check WebGUI::Middleware::Session'; + + # Handle the request + handle($session); + + # Construct the PSGI response + my $response = $session->response; + my $psgi_response = $response->finalize; + + # 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] ] ); + + # Store the writer object in the WebGUI::Session::Response object + $response->writer($writer); + + # Now call the callback that does the streaming + $response->streamer->($session); + + # 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); } }; } diff --git a/var/site.psgi b/var/site.psgi index 2db3bdf59..0ee062f69 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -45,10 +45,10 @@ builder { # 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'))->to_app; + Plack::App::File->new(root => $config->get('uploadsPath')); }; # Return the app - mount '/' => $wg->to_app; + mount '/' => $wg; }; From 7ff307cabe629e5e0755504e6bdd8055ad566b42 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 19:31:46 -0500 Subject: [PATCH 62/92] fix double sub def in WebGUI::SQL --- lib/WebGUI/SQL.pm | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/lib/WebGUI/SQL.pm b/lib/WebGUI/SQL.pm index de5c892f5..1bc6445a3 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -803,24 +803,6 @@ sub quoteIdentifier { #------------------------------------------------------------------- -=head2 quoteIdentifier ( string ) - -Returns a string quoted as an identifier to be used as a table name, column name, etc. - -=head3 string - -Any scalar variable that needs to be escaped to be inserted into the database. - -=cut - -sub quoteIdentifier { - my $self = shift; - my $value = shift; - return $self->dbh->quote_identifier($value); -} - -#------------------------------------------------------------------- - =head2 read ( sql [ , placeholders ] ) This is a convenience method for WebGUI::SQL::ResultSet->read(). It returns the statement From 1150528b8a5a3f4686f82e796c500471fb6ebe1a Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 20:13:42 -0500 Subject: [PATCH 63/92] delete WebGUI::Session::Os --- lib/WebGUI/Session.pm | 22 +--------- lib/WebGUI/Session/Os.pm | 88 ---------------------------------------- sbin/fileImport.pl | 2 +- sbin/testEnvironment.pl | 2 +- t/Session/Os.t | 52 ------------------------ 5 files changed, 4 insertions(+), 162 deletions(-) delete mode 100644 lib/WebGUI/Session/Os.pm delete mode 100644 t/Session/Os.t diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 3ceca9acf..0035ade0b 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -68,7 +68,6 @@ 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 @@ -145,7 +144,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 _response _request/) { + 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}; } } @@ -454,7 +453,7 @@ Uses simple session vars. See WebGUI::Session::Var::new() for more details. sub open { my ($class, $c, $env, $sessionId, $noFuss) = @_; my $config = ref $c ? $c : WebGUI::Config->new($c); - my $self = {_config=>$config }; # TODO - if we store reference here, should we weaken WebGUI->config? + my $self = { _config => $config }; bless $self, $class; if ($env) { @@ -493,23 +492,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 ( ) diff --git a/lib/WebGUI/Session/Os.pm b/lib/WebGUI/Session/Os.pm deleted file mode 100644 index 80ebd7c10..000000000 --- a/lib/WebGUI/Session/Os.pm +++ /dev/null @@ -1,88 +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 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/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 c6b06b009..97d31765d 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, 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"); -} - From ad68c7bd199023e37c8754e80acae8bfa7205ab6 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 16 Apr 2010 20:14:32 -0500 Subject: [PATCH 64/92] note new module versions --- sbin/testEnvironment.pl | 4 ++++ var/site.psgi | 1 + 2 files changed, 5 insertions(+) diff --git a/sbin/testEnvironment.pl b/sbin/testEnvironment.pl index 97d31765d..9a7a299c5 100755 --- a/sbin/testEnvironment.pl +++ b/sbin/testEnvironment.pl @@ -110,6 +110,9 @@ checkModule("POE::Component::IKC::Server", 0.2001 ); checkModule("POE::Component::Client::HTTP", 0.88 ); checkModule("Plack::Request"); checkModule("Plack::Response"); +checkModule("Plack::Middleware::Status"); +checkModule("Plack::Middleware::Debug"); +checkModule("Plack::Middleware::ForwardedHeaders"); checkModule("URI::Escape", "3.29" ); checkModule("POSIX" ); checkModule("List::Util" ); @@ -141,6 +144,7 @@ checkModule("Readonly", "1.03" ); checkModule("Memcached::libmemcached", "0.3102" ); checkModule("Moose", "0.93" ); checkModule("MooseX::Storage", "0.23" ); +checkModule("MooseX::NonMoose", '0.07' ); checkModule("namespace::autoclean", "0.09" ); checkModule("Business::PayPal::API", "0.62" ); checkModule("Locales", "0.10" ); diff --git a/var/site.psgi b/var/site.psgi index 0ee062f69..dfd2cc339 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -10,6 +10,7 @@ builder { my $wg = WebGUI->new( site => $ENV{WEBGUI_CONFIG} ); my $config = $wg->config; + enable 'ForwardedHeaders'; enable 'Log4perl', category => $config->getFilename, conf => WebGUI::Paths->logConfig; # Reproduce URL handler functionality with middleware From 9621120825eba1bc8c8e704ddc0909acb34639ec Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 17 Apr 2010 19:06:07 -0400 Subject: [PATCH 65/92] PSGI improvements Call to_app() explicitly rather than using Plack::Component's overload Compile the psgi sub once per app, not once per req --- lib/WebGUI.pm | 115 +++++++++++++++++-------------- lib/WebGUI/Middleware/Session.pm | 4 -- lib/WebGUI/Session.pm | 1 - lib/WebGUI/Session/Form.pm | 1 + lib/WebGUI/Session/Http.pm | 3 +- var/site.psgi | 2 +- 6 files changed, 66 insertions(+), 60 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 613b5ccc4..a969730b7 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -22,11 +22,9 @@ our $STATUS = 'beta'; use strict; use Moose; use MooseX::NonMoose; - use WebGUI::Config; use WebGUI::Pluggable; use WebGUI::Paths; - use Try::Tiny; extends 'Plack::Component'; @@ -64,60 +62,71 @@ has site => ( }, ); +sub prepare_app { + my $self = shift; + + # WebGUI is a PSGI app is a Perl code reference. Let's create one (once). + + # Each web request results in a call to this sub + $self->{psgi_app} = sub { + my $env = shift; + + # 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'; + + # Handle the request + handle($session); + + # Construct the PSGI response + my $response = $session->response; + my $psgi_response = $response->finalize; + + # 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] ] ); + + # Store the writer object in the WebGUI::Session::Response object + $response->writer($writer); + + # Now call the callback that does the streaming + $response->streamer->($session); + + # 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); + } + }; + }; +} + # Each web request results in a call to this sub sub call { my $self = shift; - my $env = shift; - - # 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'; - - # Handle the request - handle($session); - - # Construct the PSGI response - my $response = $session->response; - my $psgi_response = $response->finalize; - - # 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] ] ); - - # Store the writer object in the WebGUI::Session::Response object - $response->writer($writer); - - # Now call the callback that does the streaming - $response->streamer->($session); - - # 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); - } - }; + return $self->{psgi_app}->(@_); } sub handle { diff --git a/lib/WebGUI/Middleware/Session.pm b/lib/WebGUI/Middleware/Session.pm index 3d4f4e303..4e9014d79 100644 --- a/lib/WebGUI/Middleware/Session.pm +++ b/lib/WebGUI/Middleware/Session.pm @@ -68,11 +68,7 @@ sub call { # Close the Session $env->{'webgui.session'}->close(); - #memory_cycle_ok( $env->{'webgui.session'} ); delete $env->{'webgui.session'}; - - #use Test::Memory::Cycle; - #memory_cycle_ok( $env ); } ); } diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 0035ade0b..10dc97c4b 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -26,7 +26,6 @@ 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; diff --git a/lib/WebGUI/Session/Form.pm b/lib/WebGUI/Session/Form.pm index 42f252072..e773ed408 100644 --- a/lib/WebGUI/Session/Form.pm +++ b/lib/WebGUI/Session/Form.pm @@ -63,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); } diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 8f09c08fe..15c3fa257 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -231,7 +231,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; } diff --git a/var/site.psgi b/var/site.psgi index dfd2cc339..8d684c7fa 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -50,6 +50,6 @@ builder { }; # Return the app - mount '/' => $wg; + mount '/' => $wg->to_app; }; From 8b05bc9f4da3025d98d71da138e7f59d28065e1e Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 17 Apr 2010 19:37:46 -0400 Subject: [PATCH 66/92] Temporary preloading --- var/site.psgi | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/var/site.psgi b/var/site.psgi index 8d684c7fa..811f4e9bf 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -2,7 +2,9 @@ use strict; use Plack::Builder; use Plack::App::File; use WebGUI; -use WebGUI::Paths; +use WebGUI::Paths -preload; +use DBI; +DBI->install_driver("mysql"); use WebGUI::Middleware::Debug::Performance; my $config = $ENV{WEBGUI_CONFIG}; From ecc9967f2e397802bedac00edeb58df249a89c8c Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 17 Apr 2010 19:49:53 -0400 Subject: [PATCH 67/92] Think twice before "improving" anything Haarg has committed --- lib/WebGUI.pm | 113 +++++++++++++++++++++++--------------------------- var/site.psgi | 4 ++ 2 files changed, 55 insertions(+), 62 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index a969730b7..6cda217eb 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -62,71 +62,60 @@ has site => ( }, ); -sub prepare_app { - my $self = shift; - - # WebGUI is a PSGI app is a Perl code reference. Let's create one (once). - - # Each web request results in a call to this sub - $self->{psgi_app} = sub { - my $env = shift; - - # 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'; - - # Handle the request - handle($session); - - # Construct the PSGI response - my $response = $session->response; - my $psgi_response = $response->finalize; - - # 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] ] ); - - # Store the writer object in the WebGUI::Session::Response object - $response->writer($writer); - - # Now call the callback that does the streaming - $response->streamer->($session); - - # 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); - } - }; - }; -} - # Each web request results in a call to this sub sub call { my $self = shift; - return $self->{psgi_app}->(@_); + my $env = shift; + + # 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'; + + # Handle the request + handle($session); + + # Construct the PSGI response + my $response = $session->response; + my $psgi_response = $response->finalize; + + # 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] ] ); + + # Store the writer object in the WebGUI::Session::Response object + $response->writer($writer); + + # Now call the callback that does the streaming + $response->streamer->($session); + + # 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 { diff --git a/var/site.psgi b/var/site.psgi index 811f4e9bf..9176aa277 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -2,9 +2,13 @@ use strict; use Plack::Builder; use Plack::App::File; use WebGUI; + +# Temporary preload hack use WebGUI::Paths -preload; use DBI; DBI->install_driver("mysql"); +# end hack + use WebGUI::Middleware::Debug::Performance; my $config = $ENV{WEBGUI_CONFIG}; From f99f672b06937a9d77147b8fb6bbd35f74239dcd Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 17 Apr 2010 20:52:22 -0400 Subject: [PATCH 68/92] Minor refactoring --- TODO | 6 ++++-- lib/WebGUI.pm | 4 ++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/TODO b/TODO index 70fd1f4e2..b61b64347 100644 --- a/TODO +++ b/TODO @@ -1,8 +1,8 @@ TODO * Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response -* Delete lib/WebGUI/URL and replace with new Middleware(s) * Investigate moving Cookie handling into middleware -* Turn html debug output into a Plack::Middleware::Debug panel +* Replace WebGUI::authen with something equivalent +* Refactor assets to use streaming response DONE * $session->request is now a Plack::Request object @@ -12,6 +12,8 @@ DONE * 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.. diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 6cda217eb..548f17d8b 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -76,7 +76,7 @@ sub call { or die 'Missing WebGUI Session - check WebGUI::Middleware::Session'; # Handle the request - handle($session); + $self->handle($session); # Construct the PSGI response my $response = $session->response; @@ -119,7 +119,7 @@ sub call { } sub handle { - my ( $session ) = @_; + 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"); From d667f724f4d78f36500d940f9ad55eea73746766 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 13:42:40 -0500 Subject: [PATCH 69/92] fix things i broke --- lib/WebGUI/FormValidator.pm | 3 +++ lib/WebGUI/Session/DateTime.pm | 2 +- lib/WebGUI/Session/ErrorHandler.pm | 3 ++- lib/WebGUI/Session/Http.pm | 1 + 4 files changed, 7 insertions(+), 2 deletions(-) diff --git a/lib/WebGUI/FormValidator.pm b/lib/WebGUI/FormValidator.pm index bb1cada6b..9df082177 100644 --- a/lib/WebGUI/FormValidator.pm +++ b/lib/WebGUI/FormValidator.pm @@ -80,6 +80,9 @@ sub AUTOLOAD { return $control->getValue(@args); } +# so it doesn't get autoloaded +sub DESTROY {} + #------------------------------------------------------------------- =head2 get ( ) diff --git a/lib/WebGUI/Session/DateTime.pm b/lib/WebGUI/Session/DateTime.pm index cac8c12ff..bd7f0067b 100644 --- a/lib/WebGUI/Session/DateTime.pm +++ b/lib/WebGUI/Session/DateTime.pm @@ -21,7 +21,7 @@ use DateTime::Format::Mail; use DateTime::TimeZone; use Tie::IxHash; use WebGUI::International; -use WebGUI::Utility qw(round); +use WebGUI::Utility qw(round isIn); use Scalar::Util qw(weaken); diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 19c0d5a4a..a124dba13 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -207,7 +207,8 @@ sub new { # 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) - Log::Log4perl->init_once( $session->config->getWebguiRoot . "/etc/log.conf" ); + require Log::Log4perl; + Log::Log4perl->init_once( WebGUI::Paths->logConfig ); my $log4perl = Log::Log4perl->get_logger( $session->config->getFilename ); $logger = sub { my $args = shift; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 15c3fa257..8aee3ee82 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -17,6 +17,7 @@ package WebGUI::Session::Http; use strict; use Scalar::Util qw(weaken); +use WebGUI::Utility qw(isIn); use HTTP::Date (); sub _deprecated { From 5c70ffb3e08998d2324add1c2ad8606a975274f9 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 18 Apr 2010 14:51:24 -0400 Subject: [PATCH 70/92] Minor improvements Updated TODO Enabled preloading Added defaultPSGI to WebGUI::Paths Added example of testing site via Plack::Test --- TODO | 3 ++- app.psgi | 7 ++----- lib/WebGUI/Paths.pm | 1 + lib/WebGUI/Session/ErrorHandler.pm | 2 +- lib/WebGUI/Session/Form.pm | 5 +---- t/PSGI/default-site.t | 23 +++++++++++++++++++++++ var/site.psgi | 8 -------- 7 files changed, 30 insertions(+), 19 deletions(-) create mode 100644 t/PSGI/default-site.t diff --git a/TODO b/TODO index b61b64347..e771de9ba 100644 --- a/TODO +++ b/TODO @@ -1,8 +1,9 @@ TODO * Deprecate WebGUI::Session::HTTP - replace with WebGUI::Request/Response * Investigate moving Cookie handling into middleware -* Replace WebGUI::authen with something equivalent +* 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 diff --git a/app.psgi b/app.psgi index b18377b1b..09c4498e3 100644 --- a/app.psgi +++ b/app.psgi @@ -1,16 +1,13 @@ use strict; use Plack::Builder; -use WebGUI::Paths -inc; +use WebGUI::Paths -preload; use WebGUI::Config; -use File::Spec; - -my $standard_psgi = File::Spec->catfile(WebGUI::Paths->var, 'site.psgi'); builder { my $first_app; for my $config_file (WebGUI::Paths->siteConfigs) { my $config = WebGUI::Config->new($config_file); - my $psgi = $config->get('psgiFile') || $standard_psgi; + my $psgi = $config->get('psgiFile') || WebGUI::Paths->defaultPsgi; my $app = do { $ENV{WEBGUI_CONFIG} = $config_file; Plack::Util::load_psgi($psgi); 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/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index 19c0d5a4a..c6b8770cc 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -207,7 +207,7 @@ sub new { # 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) - Log::Log4perl->init_once( $session->config->getWebguiRoot . "/etc/log.conf" ); + Log::Log4perl->init_once( WebGUI::Paths->logConfig ); my $log4perl = Log::Log4perl->get_logger( $session->config->getFilename ); $logger = sub { my $args = shift; diff --git a/lib/WebGUI/Session/Form.pm b/lib/WebGUI/Session/Form.pm index e773ed408..d2e79038b 100644 --- a/lib/WebGUI/Session/Form.pm +++ b/lib/WebGUI/Session/Form.pm @@ -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/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/var/site.psgi b/var/site.psgi index 9176aa277..232cb562c 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -2,16 +2,8 @@ use strict; use Plack::Builder; use Plack::App::File; use WebGUI; - -# Temporary preload hack -use WebGUI::Paths -preload; -use DBI; -DBI->install_driver("mysql"); -# end hack - use WebGUI::Middleware::Debug::Performance; -my $config = $ENV{WEBGUI_CONFIG}; builder { my $wg = WebGUI->new( site => $ENV{WEBGUI_CONFIG} ); my $config = $wg->config; From 2a3482b1c30a9988ec4c487ed0ff25d6a1b42855 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:44:48 -0500 Subject: [PATCH 71/92] fix bad capitalization --- app.psgi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app.psgi b/app.psgi index 09c4498e3..f57478db6 100644 --- a/app.psgi +++ b/app.psgi @@ -7,7 +7,7 @@ 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 $psgi = $config->get('psgiFile') || WebGUI::Paths->defaultPSGI; my $app = do { $ENV{WEBGUI_CONFIG} = $config_file; Plack::Util::load_psgi($psgi); From 22619cfb9ab9b15ab10a060f5c8d25c580a7da82 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:47:16 -0500 Subject: [PATCH 72/92] clean up more uses of ->get --- lib/WebGUI/Asset.pm | 21 +++++----- lib/WebGUI/Asset/Wobject/Navigation.pm | 56 +++++++++++++------------- lib/WebGUI/AssetLineage.pm | 4 +- lib/WebGUI/Session/Url.pm | 2 +- 4 files changed, 42 insertions(+), 41 deletions(-) diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 3312a29fc..0b2e2cec4 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -564,10 +564,10 @@ sub canView { $user = $self->session->user; $userId = $user->userId(); } - if ($userId eq $self->get("ownerUserId")) { + if ($userId eq $self->ownerUserId) { return 1; } - elsif ($user->isInGroup($self->get("groupIdView"))) { + elsif ($user->isInGroup($self->groupIdView)) { return 1; } return $self->canEdit($userId); @@ -1181,9 +1181,9 @@ Returns the extraHeadTags stored in the asset. Called in $self->session->style- sub getExtraHeadTags { my $self = shift; - return $self->get('usePackedHeadTags') - ? $self->get('extraHeadTagsPacked') - : $self->get("extraHeadTags") + return $self->usePackedHeadTags + ? $self->extraHeadTagsPacked + : $self->extraHeadTags ; } @@ -1368,11 +1368,12 @@ Returns the menu title of this asset. If it's not specified or it's "Untitled" t =cut sub getMenuTitle { - my $self = shift; - if ($self->get("menuTitle") eq "" || lc($self->get("menuTitle")) eq "untitled") { - return $self->getName; - } - return $self->get("menuTitle"); + my $self = shift; + my $menuTitle = $self->menuTitle; + if ( $menuTitle eq '' || lc $menuTitle eq 'untitled' ) { + return $self->getName; + } + return $menuTitle; } diff --git a/lib/WebGUI/Asset/Wobject/Navigation.pm b/lib/WebGUI/Asset/Wobject/Navigation.pm index 51ad00626..67308aa29 100644 --- a/lib/WebGUI/Asset/Wobject/Navigation.pm +++ b/lib/WebGUI/Asset/Wobject/Navigation.pm @@ -304,7 +304,7 @@ override getToolbar => sub { if ($self->session->asset) { $returnUrl = ";proceed=goBackToPage;returnUrl=".$self->session->url->escape($self->session->asset->getUrl); } - $toolbar = $self->session->icon->edit('func=edit'.$returnUrl,$self->get("url")) + $toolbar = $self->session->icon->edit('func=edit'.$returnUrl,$self->url) if ($userUiLevel >= $uiLevels->{"edit"}); } $self->session->style->setLink($self->session->url->extras('assetToolbar/assetToolbar.css'), {rel=>"stylesheet",type=>"text/css"}); @@ -343,11 +343,11 @@ Extend the superclass to add metadata and to preprocess the template. sub prepareView { my $self = shift; $self->SUPER::prepareView(); - my $template = WebGUI::Asset::Template->newById($self->session, $self->get("templateId")); + my $template = WebGUI::Asset::Template->newById($self->session, $self->templateId); if (!$template) { WebGUI::Error::ObjectNotFound::Template->throw( error => qq{Template not found}, - templateId => $self->get("templateId"), + templateId => $self->templateId, assetId => $self->getId, ); } @@ -376,29 +376,29 @@ sub view { $current = WebGUI::Asset->getDefault($self->session); } - if ($self->get("startType") eq "specificUrl") { - $start = WebGUI::Asset->newByUrl($self->session,$self->get("startPoint")); - } elsif ($self->get("startType") eq "relativeToRoot") { - unless (($self->get("startPoint")+1) >= $current->getLineageLength) { - $start = WebGUI::Asset->newByLineage($self->session,substr($current->get("lineage"),0, ($self->get("startPoint") + 1) * 6)); + if ($self->startType eq "specificUrl") { + $start = WebGUI::Asset->newByUrl($self->session,$self->startPoint); + } elsif ($self->startType eq "relativeToRoot") { + unless (($self->startPoint+1) >= $current->getLineageLength) { + $start = WebGUI::Asset->newByLineage($self->session,substr($current->lineage,0, ($self->startPoint + 1) * 6)); } - } elsif ($self->get("startType") eq "relativeToCurrentUrl") { - $start = WebGUI::Asset->newByLineage($self->session,substr($current->get("lineage"),0, ($current->getLineageLength + $self->get("startPoint")) * 6)); + } elsif ($self->startType eq "relativeToCurrentUrl") { + $start = WebGUI::Asset->newByLineage($self->session,substr($current->lineage,0, ($current->getLineageLength + $self->startPoint) * 6)); } $start = $current unless (defined $start); # if none of the above results in a start point, then the current page must be it - my @includedRelationships = split("\n",$self->get("assetsToInclude")); + my @includedRelationships = split("\n",$self->assetsToInclude); my %rules; $rules{returnObjects} = 1; - $rules{endingLineageLength} = $start->getLineageLength+$self->get("descendantEndPoint"); + $rules{endingLineageLength} = $start->getLineageLength+$self->descendantEndPoint; $rules{assetToPedigree} = $current if (isIn("pedigree",@includedRelationships)); - $rules{ancestorLimit} = $self->get("ancestorEndPoint"); - $rules{orderByClause} = 'rpad(asset.lineage, 255, 9) desc' if ($self->get('reversePageLoop')); + $rules{ancestorLimit} = $self->ancestorEndPoint; + $rules{orderByClause} = 'rpad(asset.lineage, 255, 9) desc' if ($self->reversePageLoop); my @interestingProperties = ('assetId', 'parentId', 'ownerUserId', 'synopsis', 'newWindow'); my $assets = $start->getLineage(\@includedRelationships,\%rules); my $var = {'page_loop' => []}; foreach my $property (@interestingProperties) { - $var->{'currentPage.'.$property} = $current->get($property); + $var->{'currentPage.'.$property} = $current->$property; } $var->{'currentPage.menuTitle'} = $current->getMenuTitle; $var->{'currentPage.title'} = $current->getTitle; @@ -407,7 +407,7 @@ sub view { $var->{'currentPage.hasChild'} = $current->hasChildren; $var->{'currentPage.rank'} = $current->getRank; $var->{'currentPage.rankIs'.$current->getRank} = 1; - my $currentLineage = $current->get("lineage"); + my $currentLineage = $current->lineage; my $lineageToSkip = "noskip"; my $absoluteDepthOfLastPage; my $absoluteDepthOfFirstPage; # Will set on first iteration of loop, below @@ -417,18 +417,18 @@ sub view { foreach my $asset (@{$assets}) { # skip pages we shouldn't see - my $pageLineage = $asset->get("lineage"); + my $pageLineage = $asset->lineage; next if ($pageLineage =~ m/^$lineageToSkip/); - if ($asset->get("isHidden") && !$self->get("showHiddenPages")) { + if ($asset->isHidden && !$self->showHiddenPages) { $lineageToSkip = $pageLineage unless ($pageLineage eq "000001"); next; } - if ($asset->get("isSystem") && !$self->get("showSystemPages")) { + if ($asset->isSystem && !$self->showSystemPages) { $lineageToSkip = $pageLineage unless ($pageLineage eq "000001"); next; } - unless ($self->get("showUnprivilegedPages") || $asset->canView) { + unless ($self->showUnprivilegedPages || $asset->canView) { $lineageToSkip = $pageLineage unless ($pageLineage eq "000001"); next; } @@ -450,11 +450,11 @@ sub view { $pageData->{"page.rank"} = $asset->getRank; $pageData->{"page.absDepth"} = $asset->getLineageLength; $pageData->{"page.relDepth"} = $asset->getLineageLength - $absoluteDepthOfFirstPage; - $pageData->{"page.isSystem"} = $asset->get("isSystem"); - $pageData->{"page.isHidden"} = $asset->get("isHidden"); + $pageData->{"page.isSystem"} = $asset->isSystem; + $pageData->{"page.isHidden"} = $asset->isHidden; $pageData->{"page.isViewable"} = $asset->canView; - $pageData->{'page.isContainer'} = $self->session->config->get("assets/".$asset->get("className")."/isContainer"); - $pageData->{'page.isUtility'} = $self->session->config->get("assets/".$asset->get("className")."/category") eq "utilities"; + $pageData->{'page.isContainer'} = $self->session->config->get("assets/".$asset->className."/isContainer"); + $pageData->{'page.isUtility'} = $self->session->config->get("assets/".$asset->className."/category") eq "utilities"; $pageData->{"page.url"} = $asset->getUrl; my $indent = $asset->getLineageLength - $absoluteDepthOfFirstPage; $pageData->{"page.indent_loop"} = []; @@ -462,15 +462,15 @@ sub view { $pageData->{"page.indent"} = "   " x $indent; $pageData->{"page.isBranchRoot"} = ($pageData->{"page.absDepth"} == 1); $pageData->{"page.isTopOfBranch"} = ($pageData->{"page.absDepth"} == 2); - $pageData->{"page.isChild"} = ($asset->get("parentId") eq $current->getId); - $pageData->{"page.isParent"} = ($asset->getId eq $current->get("parentId")); + $pageData->{"page.isChild"} = ($asset->parentId eq $current->getId); + $pageData->{"page.isParent"} = ($asset->getId eq $current->parentId); $pageData->{"page.isCurrent"} = ($asset->getId eq $current->getId); $pageData->{"page.isDescendant"} = ( $pageLineage =~ m/^$currentLineage/ && !$pageData->{"page.isCurrent"}); $pageData->{"page.isAncestor"} = ( $currentLineage =~ m/^$pageLineage/ && !$pageData->{"page.isCurrent"}); my $currentBranchLineage = substr($currentLineage,0,12); $pageData->{"page.inBranchRoot"} = ($pageLineage =~ m/^$currentBranchLineage/); $pageData->{"page.isSibling"} = ( - $asset->get("parentId") eq $current->get("parentId") && + $asset->parentId eq $current->parentId && $asset->getId ne $current->getId ); $pageData->{"page.inBranch"} = ( @@ -499,7 +499,7 @@ sub view { my $parent = $asset->getParent; if (defined $parent) { foreach my $property (@interestingProperties) { - $pageData->{"page.parent.".$property} = $parent->get($property); + $pageData->{"page.parent.".$property} = $parent->$property; } $pageData->{'page.parent.menuTitle'} = $parent->getMenuTitle; $pageData->{'page.parent.title'} = $parent->getTitle; diff --git a/lib/WebGUI/AssetLineage.pm b/lib/WebGUI/AssetLineage.pm index 0507afddf..4e239715d 100644 --- a/lib/WebGUI/AssetLineage.pm +++ b/lib/WebGUI/AssetLineage.pm @@ -483,7 +483,7 @@ Returns the number of Asset members in an Asset's lineage. sub getLineageLength { my $self = shift; - return length($self->get("lineage"))/6; + return length($self->lineage)/6; } #------------------------------------------------------------------- @@ -773,7 +773,7 @@ Optional specified lineage. sub getRank { my $self = shift; - my $lineage = shift || $self->get("lineage"); + my $lineage = shift || $self->lineage; $lineage =~ m/(.{6})$/; my $rank = $1 - 0; # gets rid of preceeding 0s. return $rank; diff --git a/lib/WebGUI/Session/Url.pm b/lib/WebGUI/Session/Url.pm index 7de9755dd..c90e32390 100644 --- a/lib/WebGUI/Session/Url.pm +++ b/lib/WebGUI/Session/Url.pm @@ -457,7 +457,7 @@ sub page { if ($useFullUrl) { $url = $self->getSiteURL(); } - my $path = $self->session->asset ? $self->session->asset->get("url") : URI::Escape::uri_escape_utf8($self->getRequestedUrl, "^A-Za-z0-9\-_.!~*'()/"); + my $path = $self->session->asset ? $self->session->asset->url : URI::Escape::uri_escape_utf8($self->getRequestedUrl, "^A-Za-z0-9\-_.!~*'()/"); $url .= $self->gateway($path, $pairs, $skipPreventProxyCache); return $url; } From 83dbe97687b9de3433a7ee24ea0a7af127e94921 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:48:59 -0500 Subject: [PATCH 73/92] more object destruction cleanups --- lib/WebGUI/Asset.pm | 21 --------------------- lib/WebGUI/Asset/Post.pm | 9 ++++----- lib/WebGUI/Asset/Post/Thread.pm | 13 ++++++------- lib/WebGUI/Asset/Wobject/GalleryAlbum.pm | 2 +- 4 files changed, 11 insertions(+), 34 deletions(-) diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 0b2e2cec4..f19db9fb7 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -663,27 +663,6 @@ sub drawExtraHeadTags { }); } - -#------------------------------------------------------------------- - -=head2 DESTROY ( ) - -Completely remove an asset from existence. - -=cut - -sub DESTROY { - my $self = shift; - - # Let the parent be garbage collected if no one else is referencing - # him. firstChild and lastChild are weak references, so no need to - # worry about them here. - delete $self->{_parent}; - - $self = undef; -} - - #------------------------------------------------------------------- =head2 extraHeadTags ( value ) diff --git a/lib/WebGUI/Asset/Post.pm b/lib/WebGUI/Asset/Post.pm index 21afb2463..64e90584c 100644 --- a/lib/WebGUI/Asset/Post.pm +++ b/lib/WebGUI/Asset/Post.pm @@ -321,11 +321,10 @@ Extend the base method to delete the locally cached thread object. =cut -override DESTROY => sub { - my $self = shift; - $self->{_thread}->DESTROY if (exists $self->{_thread} && ref $self->{_thread} =~ /Thread/); - super(); -}; +sub DEMOLISH { + my $self = shift; + $self->{_thread}->DESTROY if (exists $self->{_thread} && ref $self->{_thread} =~ /Thread/); +} #------------------------------------------------------------------- diff --git a/lib/WebGUI/Asset/Post/Thread.pm b/lib/WebGUI/Asset/Post/Thread.pm index 01d1bc773..cb555d1e8 100644 --- a/lib/WebGUI/Asset/Post/Thread.pm +++ b/lib/WebGUI/Asset/Post/Thread.pm @@ -238,13 +238,12 @@ and next threads, and to delete the parent CS. =cut -override DESTROY => sub { - my $self = shift; - return undef unless defined $self; - $self->{_next}->DESTROY if (defined $self->{_next}); - $self->{_previous}->DESTROY if (defined $self->{_previous}); - super(); -}; +sub DEMOLISH { + my $self = shift; + return undef unless defined $self; + $self->{_next}->DESTROY if (defined $self->{_next}); + $self->{_previous}->DESTROY if (defined $self->{_previous}); +} #------------------------------------------------------------------- diff --git a/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm b/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm index 75a18c667..c0ed7a479 100644 --- a/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm +++ b/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm @@ -312,7 +312,7 @@ Destroy the cached assets =cut -sub DESTROY { +sub DEMOLISH { my $self = shift; for my $key ( qw/ _nextAlbum _prevAlbum / ) { my $asset = delete $self->{ $key }; From 8186754b8604001df3179f7281b99c2519dfa862 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:50:56 -0500 Subject: [PATCH 74/92] asset immutability --- lib/WebGUI/Asset.pm | 1 + lib/WebGUI/Asset/Event.pm | 1 + lib/WebGUI/Asset/File.pm | 2 +- lib/WebGUI/Asset/File/GalleryFile.pm | 1 + lib/WebGUI/Asset/File/GalleryFile/Photo.pm | 1 + lib/WebGUI/Asset/File/Image.pm | 1 + lib/WebGUI/Asset/File/ZipArchive.pm | 1 + lib/WebGUI/Asset/FilePile.pm | 1 + lib/WebGUI/Asset/MapPoint.pm | 1 + lib/WebGUI/Asset/MatrixListing.pm | 2 ++ lib/WebGUI/Asset/Post.pm | 2 +- lib/WebGUI/Asset/Post/Thread.pm | 1 + lib/WebGUI/Asset/Redirect.pm | 1 + lib/WebGUI/Asset/RichEdit.pm | 2 +- lib/WebGUI/Asset/Shortcut.pm | 1 + lib/WebGUI/Asset/Sku.pm | 1 + lib/WebGUI/Asset/Sku/Ad.pm | 1 + lib/WebGUI/Asset/Sku/Donation.pm | 1 + lib/WebGUI/Asset/Sku/EMSBadge.pm | 1 + lib/WebGUI/Asset/Sku/EMSRibbon.pm | 1 + lib/WebGUI/Asset/Sku/EMSTicket.pm | 1 + lib/WebGUI/Asset/Sku/EMSToken.pm | 1 + lib/WebGUI/Asset/Sku/FlatDiscount.pm | 1 + lib/WebGUI/Asset/Sku/Product.pm | 1 + lib/WebGUI/Asset/Sku/Subscription.pm | 1 + lib/WebGUI/Asset/Sku/ThingyRecord.pm | 1 + lib/WebGUI/Asset/Snippet.pm | 2 +- lib/WebGUI/Asset/Story.pm | 1 + lib/WebGUI/Asset/Template.pm | 1 + lib/WebGUI/Asset/WikiPage.pm | 2 +- lib/WebGUI/Asset/Wobject.pm | 1 + lib/WebGUI/Asset/Wobject/Article.pm | 1 + lib/WebGUI/Asset/Wobject/Calendar.pm | 1 + lib/WebGUI/Asset/Wobject/Carousel.pm | 1 + lib/WebGUI/Asset/Wobject/Collaboration.pm | 1 + lib/WebGUI/Asset/Wobject/Collaboration/Newsletter.pm | 1 + lib/WebGUI/Asset/Wobject/Dashboard.pm | 1 + lib/WebGUI/Asset/Wobject/DataForm.pm | 1 + lib/WebGUI/Asset/Wobject/DataTable.pm | 1 + lib/WebGUI/Asset/Wobject/EventManagementSystem.pm | 1 + lib/WebGUI/Asset/Wobject/Folder.pm | 1 + lib/WebGUI/Asset/Wobject/Gallery.pm | 1 + lib/WebGUI/Asset/Wobject/GalleryAlbum.pm | 1 + lib/WebGUI/Asset/Wobject/HttpProxy.pm | 1 + lib/WebGUI/Asset/Wobject/InOutBoard.pm | 1 + lib/WebGUI/Asset/Wobject/Layout.pm | 1 + lib/WebGUI/Asset/Wobject/Map.pm | 1 + lib/WebGUI/Asset/Wobject/Matrix.pm | 1 + lib/WebGUI/Asset/Wobject/MessageBoard.pm | 1 + lib/WebGUI/Asset/Wobject/MultiSearch.pm | 1 + lib/WebGUI/Asset/Wobject/Navigation.pm | 1 + lib/WebGUI/Asset/Wobject/Poll.pm | 1 + lib/WebGUI/Asset/Wobject/ProjectManager.pm | 2 +- lib/WebGUI/Asset/Wobject/SQLReport.pm | 1 + lib/WebGUI/Asset/Wobject/Search.pm | 1 + lib/WebGUI/Asset/Wobject/Shelf.pm | 1 + lib/WebGUI/Asset/Wobject/StockData.pm | 1 + lib/WebGUI/Asset/Wobject/StoryArchive.pm | 1 + lib/WebGUI/Asset/Wobject/StoryTopic.pm | 1 + lib/WebGUI/Asset/Wobject/Survey.pm | 1 + lib/WebGUI/Asset/Wobject/SyndicatedContent.pm | 1 + lib/WebGUI/Asset/Wobject/Thingy.pm | 1 + lib/WebGUI/Asset/Wobject/TimeTracking.pm | 1 + lib/WebGUI/Asset/Wobject/UserList.pm | 1 + lib/WebGUI/Asset/Wobject/WeatherData.pm | 1 + lib/WebGUI/Asset/Wobject/WikiMaster.pm | 1 + lib/WebGUI/Definition/Meta/Asset.pm | 10 +++++++++- lib/WebGUI/Definition/Meta/Class.pm | 8 ++++++++ 68 files changed, 84 insertions(+), 7 deletions(-) diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index f19db9fb7..4fe8ff277 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -2838,4 +2838,5 @@ sub www_widgetView { return $self->outputWidgetMarkup($width, $height, $templateId, $styleTemplateId); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Event.pm b/lib/WebGUI/Asset/Event.pm index 6f46b5665..9022b8cad 100644 --- a/lib/WebGUI/Asset/Event.pm +++ b/lib/WebGUI/Asset/Event.pm @@ -2360,5 +2360,6 @@ equal and then choose by assetId. =cut +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/File.pm b/lib/WebGUI/Asset/File.pm index 85088f2b0..6617c800c 100644 --- a/lib/WebGUI/Asset/File.pm +++ b/lib/WebGUI/Asset/File.pm @@ -649,5 +649,5 @@ sub www_view { return 'chunked'; } - +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/File/GalleryFile.pm b/lib/WebGUI/Asset/File/GalleryFile.pm index f812a69ba..642a7c405 100644 --- a/lib/WebGUI/Asset/File/GalleryFile.pm +++ b/lib/WebGUI/Asset/File/GalleryFile.pm @@ -1184,4 +1184,5 @@ sub setPrivileges { } +__PACKAGE__->meta->make_immutable; 1; # Who knew the truth would be so obvious? diff --git a/lib/WebGUI/Asset/File/GalleryFile/Photo.pm b/lib/WebGUI/Asset/File/GalleryFile/Photo.pm index fd30cb0f1..c288a6f3b 100644 --- a/lib/WebGUI/Asset/File/GalleryFile/Photo.pm +++ b/lib/WebGUI/Asset/File/GalleryFile/Photo.pm @@ -585,4 +585,5 @@ sub www_showConfirmation { ); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/File/Image.pm b/lib/WebGUI/Asset/File/Image.pm index 3e31ddef3..ed43336dd 100644 --- a/lib/WebGUI/Asset/File/Image.pm +++ b/lib/WebGUI/Asset/File/Image.pm @@ -824,4 +824,5 @@ sub www_crop { return $self->getAdminConsole->render($f->print.$image,$i18n->get("crop image")); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/File/ZipArchive.pm b/lib/WebGUI/Asset/File/ZipArchive.pm index c5b892836..489cc87d5 100644 --- a/lib/WebGUI/Asset/File/ZipArchive.pm +++ b/lib/WebGUI/Asset/File/ZipArchive.pm @@ -252,5 +252,6 @@ sub www_view { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/FilePile.pm b/lib/WebGUI/Asset/FilePile.pm index 22cef39fe..17b9ac227 100644 --- a/lib/WebGUI/Asset/FilePile.pm +++ b/lib/WebGUI/Asset/FilePile.pm @@ -270,5 +270,6 @@ sub www_edit { } } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/MapPoint.pm b/lib/WebGUI/Asset/MapPoint.pm index 616c24e08..85bfff70d 100644 --- a/lib/WebGUI/Asset/MapPoint.pm +++ b/lib/WebGUI/Asset/MapPoint.pm @@ -390,6 +390,7 @@ sub www_view { return "redirect"; } +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/MatrixListing.pm b/lib/WebGUI/Asset/MatrixListing.pm index 921039b10..2cb7893a8 100644 --- a/lib/WebGUI/Asset/MatrixListing.pm +++ b/lib/WebGUI/Asset/MatrixListing.pm @@ -1090,6 +1090,8 @@ sub www_viewScreenshots { return $self->processTemplate($var,$self->getParent->get("screenshotsTemplateId")); } + +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Post.pm b/lib/WebGUI/Asset/Post.pm index 64e90584c..07637dba2 100644 --- a/lib/WebGUI/Asset/Post.pm +++ b/lib/WebGUI/Asset/Post.pm @@ -1818,6 +1818,6 @@ sub www_view { return $self->getThread->www_view($self); } - +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Post/Thread.pm b/lib/WebGUI/Asset/Post/Thread.pm index cb555d1e8..1a6f11821 100644 --- a/lib/WebGUI/Asset/Post/Thread.pm +++ b/lib/WebGUI/Asset/Post/Thread.pm @@ -1394,5 +1394,6 @@ sub www_view { +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Redirect.pm b/lib/WebGUI/Asset/Redirect.pm index 77369912d..a5ad06223 100644 --- a/lib/WebGUI/Asset/Redirect.pm +++ b/lib/WebGUI/Asset/Redirect.pm @@ -136,5 +136,6 @@ sub www_view { return $i18n->get('self_referential'); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/RichEdit.pm b/lib/WebGUI/Asset/RichEdit.pm index b583f8395..490e192e7 100644 --- a/lib/WebGUI/Asset/RichEdit.pm +++ b/lib/WebGUI/Asset/RichEdit.pm @@ -676,6 +676,6 @@ sub www_edit { } - +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Shortcut.pm b/lib/WebGUI/Asset/Shortcut.pm index e793f8938..7198be202 100644 --- a/lib/WebGUI/Asset/Shortcut.pm +++ b/lib/WebGUI/Asset/Shortcut.pm @@ -1288,5 +1288,6 @@ sub getShortcutsForAssetId { return WebGUI::Asset->getRoot($session)->getLineage(['descendants'], $properties); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku.pm b/lib/WebGUI/Asset/Sku.pm index d6a2498a6..d9f16f7d5 100644 --- a/lib/WebGUI/Asset/Sku.pm +++ b/lib/WebGUI/Asset/Sku.pm @@ -672,4 +672,5 @@ sub www_view { return "chunked"; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/Ad.pm b/lib/WebGUI/Asset/Sku/Ad.pm index 02e925d49..b3a7dcd26 100644 --- a/lib/WebGUI/Asset/Sku/Ad.pm +++ b/lib/WebGUI/Asset/Sku/Ad.pm @@ -622,5 +622,6 @@ sub www_renew { return $self->www_view; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/Donation.pm b/lib/WebGUI/Asset/Sku/Donation.pm index a3e2db681..485e340a6 100644 --- a/lib/WebGUI/Asset/Sku/Donation.pm +++ b/lib/WebGUI/Asset/Sku/Donation.pm @@ -187,4 +187,5 @@ sub www_donate { return $self->www_view; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/EMSBadge.pm b/lib/WebGUI/Asset/Sku/EMSBadge.pm index 9777ce689..12422c2b9 100644 --- a/lib/WebGUI/Asset/Sku/EMSBadge.pm +++ b/lib/WebGUI/Asset/Sku/EMSBadge.pm @@ -519,4 +519,5 @@ sub www_edit { return $self->processStyle('

'.$i18n->get('ems badge').'

'.$self->getEditForm->print); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/EMSRibbon.pm b/lib/WebGUI/Asset/Sku/EMSRibbon.pm index 6aebc89d6..b510b2de9 100644 --- a/lib/WebGUI/Asset/Sku/EMSRibbon.pm +++ b/lib/WebGUI/Asset/Sku/EMSRibbon.pm @@ -287,4 +287,5 @@ sub www_viewAll { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/EMSTicket.pm b/lib/WebGUI/Asset/Sku/EMSTicket.pm index 5b7dd8411..23688db94 100644 --- a/lib/WebGUI/Asset/Sku/EMSTicket.pm +++ b/lib/WebGUI/Asset/Sku/EMSTicket.pm @@ -591,4 +591,5 @@ sub www_viewAll { +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/EMSToken.pm b/lib/WebGUI/Asset/Sku/EMSToken.pm index 1cb38e7d7..5ecb9c084 100644 --- a/lib/WebGUI/Asset/Sku/EMSToken.pm +++ b/lib/WebGUI/Asset/Sku/EMSToken.pm @@ -281,4 +281,5 @@ sub www_viewAll { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/FlatDiscount.pm b/lib/WebGUI/Asset/Sku/FlatDiscount.pm index 770119c4a..f25926bab 100644 --- a/lib/WebGUI/Asset/Sku/FlatDiscount.pm +++ b/lib/WebGUI/Asset/Sku/FlatDiscount.pm @@ -239,4 +239,5 @@ sub www_addToCart { return $self->www_view; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/Product.pm b/lib/WebGUI/Asset/Sku/Product.pm index e5fec5b86..0cefe97c8 100644 --- a/lib/WebGUI/Asset/Sku/Product.pm +++ b/lib/WebGUI/Asset/Sku/Product.pm @@ -1879,5 +1879,6 @@ override www_view => sub { super(); }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/Subscription.pm b/lib/WebGUI/Asset/Sku/Subscription.pm index b6f88bd88..9d89dd4ec 100644 --- a/lib/WebGUI/Asset/Sku/Subscription.pm +++ b/lib/WebGUI/Asset/Sku/Subscription.pm @@ -1011,5 +1011,6 @@ sub www_redeemSubscriptionCode { return $self->processStyle($self->processTemplate($var, $self->redeemSubscriptionCodeTemplateId)); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Sku/ThingyRecord.pm b/lib/WebGUI/Asset/Sku/ThingyRecord.pm index a87725a21..d510325cd 100644 --- a/lib/WebGUI/Asset/Sku/ThingyRecord.pm +++ b/lib/WebGUI/Asset/Sku/ThingyRecord.pm @@ -721,6 +721,7 @@ sub www_renew { return $self->www_editRecord( { message => $i18n->get('renewal added to cart') . ' ^ViewCart;' } ); } ## end sub www_renew +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Snippet.pm b/lib/WebGUI/Asset/Snippet.pm index 78e998c42..f65bca0a8 100644 --- a/lib/WebGUI/Asset/Snippet.pm +++ b/lib/WebGUI/Asset/Snippet.pm @@ -312,6 +312,6 @@ sub www_view { return $output; } - +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Story.pm b/lib/WebGUI/Asset/Story.pm index 648c1852f..fe4dcbdc9 100644 --- a/lib/WebGUI/Asset/Story.pm +++ b/lib/WebGUI/Asset/Story.pm @@ -920,6 +920,7 @@ sub www_view { } +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Template.pm b/lib/WebGUI/Asset/Template.pm index 1c5bc1e37..82175ee7b 100644 --- a/lib/WebGUI/Asset/Template.pm +++ b/lib/WebGUI/Asset/Template.pm @@ -1174,5 +1174,6 @@ sub www_view { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/WikiPage.pm b/lib/WebGUI/Asset/WikiPage.pm index a8c22fb1e..caa5ac6a7 100644 --- a/lib/WebGUI/Asset/WikiPage.pm +++ b/lib/WebGUI/Asset/WikiPage.pm @@ -647,5 +647,5 @@ sub www_view { } - +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject.pm b/lib/WebGUI/Asset/Wobject.pm index 1b35dcaed..13313f0f4 100644 --- a/lib/WebGUI/Asset/Wobject.pm +++ b/lib/WebGUI/Asset/Wobject.pm @@ -517,5 +517,6 @@ sub www_view { return "chunked"; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Article.pm b/lib/WebGUI/Asset/Wobject/Article.pm index c75bca557..b457fbf6a 100644 --- a/lib/WebGUI/Asset/Wobject/Article.pm +++ b/lib/WebGUI/Asset/Wobject/Article.pm @@ -438,5 +438,6 @@ override www_view => sub { }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Calendar.pm b/lib/WebGUI/Asset/Wobject/Calendar.pm index db9b43e68..d88ea0004 100644 --- a/lib/WebGUI/Asset/Wobject/Calendar.pm +++ b/lib/WebGUI/Asset/Wobject/Calendar.pm @@ -2200,5 +2200,6 @@ toUserTimeZone methods of WebGUI::DateTime for to make less confusion. =cut +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Carousel.pm b/lib/WebGUI/Asset/Wobject/Carousel.pm index 963660eb4..61bc36be3 100644 --- a/lib/WebGUI/Asset/Wobject/Carousel.pm +++ b/lib/WebGUI/Asset/Wobject/Carousel.pm @@ -217,5 +217,6 @@ sub view { return $self->processTemplate($var, undef, $self->{_viewTemplate}); } +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Wobject/Collaboration.pm b/lib/WebGUI/Asset/Wobject/Collaboration.pm index b53992401..4b724d779 100644 --- a/lib/WebGUI/Asset/Wobject/Collaboration.pm +++ b/lib/WebGUI/Asset/Wobject/Collaboration.pm @@ -1750,5 +1750,6 @@ sub www_viewRSS { return $self->www_viewRss; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Collaboration/Newsletter.pm b/lib/WebGUI/Asset/Wobject/Collaboration/Newsletter.pm index 8d5ab9436..6bbeecb90 100644 --- a/lib/WebGUI/Asset/Wobject/Collaboration/Newsletter.pm +++ b/lib/WebGUI/Asset/Wobject/Collaboration/Newsletter.pm @@ -230,4 +230,5 @@ sub www_mySubscriptionsSave { return $self->www_view; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Dashboard.pm b/lib/WebGUI/Asset/Wobject/Dashboard.pm index 4c3f09d3c..02f6f2894 100644 --- a/lib/WebGUI/Asset/Wobject/Dashboard.pm +++ b/lib/WebGUI/Asset/Wobject/Dashboard.pm @@ -434,4 +434,5 @@ sub www_view { +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/DataForm.pm b/lib/WebGUI/Asset/Wobject/DataForm.pm index 1cde30a3b..6049abea5 100644 --- a/lib/WebGUI/Asset/Wobject/DataForm.pm +++ b/lib/WebGUI/Asset/Wobject/DataForm.pm @@ -2185,5 +2185,6 @@ sub www_process { return ''; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/DataTable.pm b/lib/WebGUI/Asset/Wobject/DataTable.pm index 9c0f570cc..adbd3e061 100644 --- a/lib/WebGUI/Asset/Wobject/DataTable.pm +++ b/lib/WebGUI/Asset/Wobject/DataTable.pm @@ -278,4 +278,5 @@ sub www_ajaxUpdateData { return $data; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/EventManagementSystem.pm b/lib/WebGUI/Asset/Wobject/EventManagementSystem.pm index 0457c7713..83a726f78 100644 --- a/lib/WebGUI/Asset/Wobject/EventManagementSystem.pm +++ b/lib/WebGUI/Asset/Wobject/EventManagementSystem.pm @@ -2766,5 +2766,6 @@ sub www_viewSubmissionQueue { $self->processTemplate( $params, $self->get('eventSubmissionMainTemplateId'))); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Folder.pm b/lib/WebGUI/Asset/Wobject/Folder.pm index 575b1eefd..673a413bb 100644 --- a/lib/WebGUI/Asset/Wobject/Folder.pm +++ b/lib/WebGUI/Asset/Wobject/Folder.pm @@ -296,5 +296,6 @@ override www_view => sub { }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Gallery.pm b/lib/WebGUI/Asset/Wobject/Gallery.pm index b19322bfa..b26614832 100644 --- a/lib/WebGUI/Asset/Wobject/Gallery.pm +++ b/lib/WebGUI/Asset/Wobject/Gallery.pm @@ -1580,4 +1580,5 @@ sub www_listFilesForUserRss { return $self->processTemplate( $var, $self->templateIdListFilesForUserRss ); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm b/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm index c0ed7a479..132d92206 100644 --- a/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm +++ b/lib/WebGUI/Asset/Wobject/GalleryAlbum.pm @@ -1612,4 +1612,5 @@ sub www_viewRss { return $self->processTemplate( $var, $self->getParent->templateIdViewAlbumRss ); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/HttpProxy.pm b/lib/WebGUI/Asset/Wobject/HttpProxy.pm index 901bcef2f..803447cab 100644 --- a/lib/WebGUI/Asset/Wobject/HttpProxy.pm +++ b/lib/WebGUI/Asset/Wobject/HttpProxy.pm @@ -507,4 +507,5 @@ sub www_view { } } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/InOutBoard.pm b/lib/WebGUI/Asset/Wobject/InOutBoard.pm index 88e62ca0b..dcc168bd4 100644 --- a/lib/WebGUI/Asset/Wobject/InOutBoard.pm +++ b/lib/WebGUI/Asset/Wobject/InOutBoard.pm @@ -566,5 +566,6 @@ order by department, lastName, firstName, InOutBoard_statusLog.dateStamp"; return $self->processStyle($self->processTemplate(\%var, $self->reportTemplateId)); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Layout.pm b/lib/WebGUI/Asset/Wobject/Layout.pm index 6ee065de9..671582994 100644 --- a/lib/WebGUI/Asset/Wobject/Layout.pm +++ b/lib/WebGUI/Asset/Wobject/Layout.pm @@ -444,5 +444,6 @@ override www_view => sub { return super(); }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Map.pm b/lib/WebGUI/Asset/Wobject/Map.pm index a9a3fe036..d05193c6d 100644 --- a/lib/WebGUI/Asset/Wobject/Map.pm +++ b/lib/WebGUI/Asset/Wobject/Map.pm @@ -631,6 +631,7 @@ sub www_ajaxSetPointLocation { return JSON->new->encode( {message => $i18n->get("message set point location")} ); } +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Wobject/Matrix.pm b/lib/WebGUI/Asset/Wobject/Matrix.pm index eaeacae0c..867ec429f 100644 --- a/lib/WebGUI/Asset/Wobject/Matrix.pm +++ b/lib/WebGUI/Asset/Wobject/Matrix.pm @@ -1447,4 +1447,5 @@ sub www_setStickied { return undef; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/MessageBoard.pm b/lib/WebGUI/Asset/Wobject/MessageBoard.pm index b2db08a68..05d8f94a4 100644 --- a/lib/WebGUI/Asset/Wobject/MessageBoard.pm +++ b/lib/WebGUI/Asset/Wobject/MessageBoard.pm @@ -172,6 +172,7 @@ override www_view => sub { super(); }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/MultiSearch.pm b/lib/WebGUI/Asset/Wobject/MultiSearch.pm index ff88000e1..b58b0e58b 100644 --- a/lib/WebGUI/Asset/Wobject/MultiSearch.pm +++ b/lib/WebGUI/Asset/Wobject/MultiSearch.pm @@ -132,4 +132,5 @@ override www_view => sub { super(); }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Navigation.pm b/lib/WebGUI/Asset/Wobject/Navigation.pm index 67308aa29..7926ef82d 100644 --- a/lib/WebGUI/Asset/Wobject/Navigation.pm +++ b/lib/WebGUI/Asset/Wobject/Navigation.pm @@ -557,5 +557,6 @@ override www_view => sub { } }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Poll.pm b/lib/WebGUI/Asset/Wobject/Poll.pm index 98b1aacc3..b56132443 100644 --- a/lib/WebGUI/Asset/Wobject/Poll.pm +++ b/lib/WebGUI/Asset/Wobject/Poll.pm @@ -557,5 +557,6 @@ sub www_vote { +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/ProjectManager.pm b/lib/WebGUI/Asset/Wobject/ProjectManager.pm index 1c7840ed1..5b3209ac9 100644 --- a/lib/WebGUI/Asset/Wobject/ProjectManager.pm +++ b/lib/WebGUI/Asset/Wobject/ProjectManager.pm @@ -1985,5 +1985,5 @@ sub www_viewProject { return $self->processStyle($self->processTemplate($var,$self->projectDisplayTemplateId)); } - +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/SQLReport.pm b/lib/WebGUI/Asset/Wobject/SQLReport.pm index 114cd3546..a7dc617cc 100644 --- a/lib/WebGUI/Asset/Wobject/SQLReport.pm +++ b/lib/WebGUI/Asset/Wobject/SQLReport.pm @@ -869,5 +869,6 @@ override www_view => sub { super(); }; +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Search.pm b/lib/WebGUI/Asset/Wobject/Search.pm index ce5329e13..33c14728b 100644 --- a/lib/WebGUI/Asset/Wobject/Search.pm +++ b/lib/WebGUI/Asset/Wobject/Search.pm @@ -208,5 +208,6 @@ sub view { return $self->processTemplate(\%var, undef, $self->{_viewTemplate}); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Shelf.pm b/lib/WebGUI/Asset/Wobject/Shelf.pm index c4bffd4e7..a46ca7ec1 100644 --- a/lib/WebGUI/Asset/Wobject/Shelf.pm +++ b/lib/WebGUI/Asset/Wobject/Shelf.pm @@ -419,4 +419,5 @@ sub www_importProducts { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/StockData.pm b/lib/WebGUI/Asset/Wobject/StockData.pm index 6a4a17031..f71b53a2d 100644 --- a/lib/WebGUI/Asset/Wobject/StockData.pm +++ b/lib/WebGUI/Asset/Wobject/StockData.pm @@ -401,4 +401,5 @@ sub www_displayStock { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/StoryArchive.pm b/lib/WebGUI/Asset/Wobject/StoryArchive.pm index fd51f84b2..8b381d3ca 100644 --- a/lib/WebGUI/Asset/Wobject/StoryArchive.pm +++ b/lib/WebGUI/Asset/Wobject/StoryArchive.pm @@ -602,5 +602,6 @@ sub www_add { $todayFolder->www_add; } +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Wobject/StoryTopic.pm b/lib/WebGUI/Asset/Wobject/StoryTopic.pm index 620648c77..53aaf03cd 100644 --- a/lib/WebGUI/Asset/Wobject/StoryTopic.pm +++ b/lib/WebGUI/Asset/Wobject/StoryTopic.pm @@ -256,5 +256,6 @@ sub www_viewStory { } +__PACKAGE__->meta->make_immutable; 1; #vim:ft=perl diff --git a/lib/WebGUI/Asset/Wobject/Survey.pm b/lib/WebGUI/Asset/Wobject/Survey.pm index e6625b054..551eb0aae 100644 --- a/lib/WebGUI/Asset/Wobject/Survey.pm +++ b/lib/WebGUI/Asset/Wobject/Survey.pm @@ -3091,4 +3091,5 @@ END_SUMMARY } } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/SyndicatedContent.pm b/lib/WebGUI/Asset/Wobject/SyndicatedContent.pm index c8efaeb82..7517a4b52 100644 --- a/lib/WebGUI/Asset/Wobject/SyndicatedContent.pm +++ b/lib/WebGUI/Asset/Wobject/SyndicatedContent.pm @@ -403,5 +403,6 @@ sub www_viewRSS20 { return $self->www_viewRss; } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/Thingy.pm b/lib/WebGUI/Asset/Wobject/Thingy.pm index 2ee798035..f554f28a4 100644 --- a/lib/WebGUI/Asset/Wobject/Thingy.pm +++ b/lib/WebGUI/Asset/Wobject/Thingy.pm @@ -3574,4 +3574,5 @@ sub www_viewThingDataViaAjax { } } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/TimeTracking.pm b/lib/WebGUI/Asset/Wobject/TimeTracking.pm index 7160d18c7..8882b452c 100644 --- a/lib/WebGUI/Asset/Wobject/TimeTracking.pm +++ b/lib/WebGUI/Asset/Wobject/TimeTracking.pm @@ -883,4 +883,5 @@ sub _buildRow { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/UserList.pm b/lib/WebGUI/Asset/Wobject/UserList.pm index 86c896cb1..3d155c858 100644 --- a/lib/WebGUI/Asset/Wobject/UserList.pm +++ b/lib/WebGUI/Asset/Wobject/UserList.pm @@ -618,4 +618,5 @@ sub view { } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/WeatherData.pm b/lib/WebGUI/Asset/Wobject/WeatherData.pm index 194fcace4..344f938a5 100644 --- a/lib/WebGUI/Asset/Wobject/WeatherData.pm +++ b/lib/WebGUI/Asset/Wobject/WeatherData.pm @@ -141,4 +141,5 @@ sub view { return $self->processTemplate(\%var, undef, $self->{_viewTemplate}); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Asset/Wobject/WikiMaster.pm b/lib/WebGUI/Asset/Wobject/WikiMaster.pm index 6320c18e3..746bfa27d 100644 --- a/lib/WebGUI/Asset/Wobject/WikiMaster.pm +++ b/lib/WebGUI/Asset/Wobject/WikiMaster.pm @@ -751,4 +751,5 @@ sub www_search { return $self->processStyle($self->processTemplate($var, $self->searchTemplateId)); } +__PACKAGE__->meta->make_immutable; 1; diff --git a/lib/WebGUI/Definition/Meta/Asset.pm b/lib/WebGUI/Definition/Meta/Asset.pm index 3e70971bc..1627b958c 100644 --- a/lib/WebGUI/Definition/Meta/Asset.pm +++ b/lib/WebGUI/Definition/Meta/Asset.pm @@ -76,9 +76,17 @@ Returns an array of the names of all tables in every class used by this class. =cut sub get_tables { + my $self = shift; + if ($self->is_immutable) { + return @{ $self->{__immutable}{get_tables_methods} ||= [ $self->_get_tables ] }; + } + goto &_get_tables; +} + +sub _get_tables { my $self = shift; my %seen = (); - my @tables = + my @tables = grep { ! $seen{$_}++ } map { $_->tableName } $self->get_all_properties diff --git a/lib/WebGUI/Definition/Meta/Class.pm b/lib/WebGUI/Definition/Meta/Class.pm index 98797db3f..1b2bab583 100644 --- a/lib/WebGUI/Definition/Meta/Class.pm +++ b/lib/WebGUI/Definition/Meta/Class.pm @@ -76,6 +76,14 @@ Returns an array of all attribute names across all meta classes. =cut sub get_all_attributes_list { + my $self = shift; + if ($self->is_immutable) { + return @{ $self->{__immutable}{get_all_attributes_list} ||= [ $self->_get_all_attributes_list ] }; + } + goto &_get_all_attributes_list; +} + +sub _get_all_attributes_list { my $self = shift; my @attributes = (); CLASS: foreach my $meta ($self->get_all_class_metas) { From cf60a9e51e05bd8768d631d8ecf9e98ba92689a9 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:51:25 -0500 Subject: [PATCH 75/92] make sure pluggable passes through exceptions --- lib/WebGUI/Pluggable.pm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/lib/WebGUI/Pluggable.pm b/lib/WebGUI/Pluggable.pm index c5608288c..80a95df9c 100644 --- a/lib/WebGUI/Pluggable.pm +++ b/lib/WebGUI/Pluggable.pm @@ -193,6 +193,9 @@ object. sub instanciate { my ($module, $sub, $params) = @_; if ( ! eval { load($module); 1 } ) { + if ( ref $@ ) { + die $@; + } croak "Could not instanciate object using $sub on $module: $@"; } # Module loaded properly @@ -229,7 +232,7 @@ my %moduleError; sub load { my $module = shift; if ($moduleError{$module}) { - croak "Could not load $module because $moduleError{$module}"; + croak $moduleError{$module}; } # Try to load the module @@ -239,8 +242,13 @@ sub load { return 1; } else { - $moduleError{$module} = $@; - croak "Could not load $module because $@"; + if ( ref $@ ) { + $moduleError{$module} = $@; + } + else { + $moduleError{$module} = "Could not load $module because $@"; + } + croak $moduleError{$module}; } } @@ -267,6 +275,8 @@ An array reference of parameters to pass in to the sub routine. sub run { my ($module, $sub, $params) = @_; if (! eval { load($module); 1 }) { + die $@ + if ref $@; croak "Unable to run $sub on $module: $@"; } elsif (my $sub = $module->can($sub)) { From 13589977f20f4a61645fb70c5eb79ad59e8091e1 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:54:21 -0500 Subject: [PATCH 76/92] don't recompute packed template on object instantiation --- lib/WebGUI/Asset/Template.pm | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/lib/WebGUI/Asset/Template.pm b/lib/WebGUI/Asset/Template.pm index 82175ee7b..e24920e9f 100644 --- a/lib/WebGUI/Asset/Template.pm +++ b/lib/WebGUI/Asset/Template.pm @@ -35,13 +35,7 @@ property template => ( sub _template_autopack { my ($self, $new, $old) = @_; return if $new eq $old; - my $packed = $new; - HTML::Packer::minify( \$packed, { - remove_comments => 1, - do_javascript => "shrink", - do_stylesheet => "minify", - } ); - $self->templatePacked($packed); + $self->_clear_templatePacked; } property isEditable => ( noFormPost => 1, @@ -78,9 +72,21 @@ property namespace => ( ); property templatePacked => ( fieldType => 'hidden', - default => undef, noFormPost => 1, + lazy => 1, + clearer => '_clear_templatePacked', + builder => '_build_templatePacked', ); +sub _build_templatePacked { + my $self = shift; + my $template = $self->template; + HTML::Packer::minify( \$template, { + remove_comments => 1, + do_javascript => 'shrink', + do_stylesheet => 'minify', + } ); +} + property usePacked => ( fieldType => 'yesNo', default => 0, From a7da8edde4430a0020a49257d677b0e478bc9f6f Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 18 Apr 2010 18:55:38 -0500 Subject: [PATCH 77/92] speed up user instantiation --- lib/WebGUI/User.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/WebGUI/User.pm b/lib/WebGUI/User.pm index f7cba2579..3bf1caea3 100644 --- a/lib/WebGUI/User.pm +++ b/lib/WebGUI/User.pm @@ -1075,7 +1075,8 @@ sub new { # Fill in dataDefault my $default = $session->db->buildHashRef( - "SELECT fieldName, dataDefault FROM userProfileField" + "SELECT fieldName, dataDefault FROM userProfileField", [], + { noOrder => 1 }, ); for my $key (keys %profile) { if (!defined $profile{$key} || $profile{$key} eq '') { From 814f6e3182dde838623b78191bbc18220929e5d6 Mon Sep 17 00:00:00 2001 From: Doug Bell Date: Tue, 20 Apr 2010 23:49:29 -0500 Subject: [PATCH 78/92] add instructions on how to try it out --- README | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/README b/README index 054eb5dd2..cec8431da 100644 --- a/README +++ b/README @@ -1,5 +1,11 @@ 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 @@ -21,4 +27,4 @@ I'm currently getting 370 requests/second, whereas I'm getting 430/second on the it and $app ($session created one per request) * $session creates the $request WebGUI::Session::Request and $response WebGUI::Session::Response objects (one per request) - \ No newline at end of file + From 7c87a34bf55df8cce46e9d4f344ac33b46d3ba98 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sat, 8 May 2010 16:35:54 -0500 Subject: [PATCH 79/92] clean up some parts of WebGUI::Test --- t/lib/WebGUI/Test.pm | 64 ++++++++++++++++++++++---------------------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index 3ed762aa5..c87a15904 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -57,8 +57,6 @@ our @EXPORT_OK = qw(session config collateral); my $CLASS = __PACKAGE__; -my @guarded; - sub import { our $CONFIG_FILE = $ENV{ WEBGUI_CONFIG }; @@ -80,7 +78,7 @@ sub _initSession { my $session = our $SESSION = $CLASS->newSession(1); my $originalSetting = clone $session->setting->get; - push @guarded, Scope::Guard->new(sub { + $CLASS->addToCleanup(sub { while (my ($param, $value) = each %{ $originalSetting }) { $session->setting->set($param, $value); } @@ -110,7 +108,7 @@ sub _initSession { my ($label, $table) = @checkCount[$i, $i+1]; $initCounts{$table} = $session->db->quickScalar('SELECT COUNT(*) FROM ' . $table); } - push @guarded, Scope::Guard->new(sub { + $CLASS->addToCleanup(sub { for ( my $i = 0; $i < @checkCount; $i += 2) { my ($label, $table) = @checkCount[$i, $i+1]; my $quant = $session->db->quickScalar('SELECT COUNT(*) FROM ' . $table); @@ -127,19 +125,6 @@ END { $CLASS->cleanup; } -sub cleanup { - # remove guards in reverse order they were added, triggering all of the - # requested cleanup operations - pop @guarded - while @guarded; - - if ( our $SESSION ) { - $SESSION->var->end; - $SESSION->close; - undef $SESSION; - } -} - #---------------------------------------------------------------------------- =head2 newSession ( $noCleanup ) @@ -159,7 +144,7 @@ sub newSession { my $session = WebGUI::Session->open( $CLASS->config ); $session->{_request} = $pseudoRequest; if ( ! $noCleanup ) { - $CLASS->sessionsToDelete($session); + $CLASS->addToCleanup($session); } return $session; } @@ -543,7 +528,7 @@ sub prepareMailServer { # Let it start up yo sleep 2; - push @guarded, Scope::Guard->new(sub { + $CLASS->addToCleanup(sub { # Close SMTPD if ($smtpdPid) { kill INT => $smtpdPid; @@ -576,7 +561,7 @@ sub originalConfig { } # add cleanup handler if this is the first time we were run if (! keys %originalConfig) { - push @guarded, Scope::Guard->new(sub { + $class->addToCleanup(sub { while (my ($key, $value) = each %originalConfig) { if (defined $value) { $CLASS->session->config->set($key, $value); @@ -592,7 +577,7 @@ sub originalConfig { #---------------------------------------------------------------------------- -=head2 getMail ( ) +=head2 getMail ( ) Read a sent mail from the prepared mail server (L) @@ -600,7 +585,7 @@ Read a sent mail from the prepared mail server (L) sub getMail { my $json; - + if ( !$smtpdSelect ) { return from_json ' { "error": "mail server not prepared" }'; } @@ -611,11 +596,11 @@ sub getMail { else { $json = ' { "error": "mail not sent" } '; } - + if (!$json) { $json = ' { "error": "error in getting mail" } '; } - + return from_json( $json ); } @@ -635,7 +620,7 @@ sub getMailFromQueue { if ( !$smtpdSelect ) { $class->prepareMailServer; } - + my $messageId = $CLASS->session->db->quickScalar( "SELECT messageId FROM mailQueue" ); warn $messageId; return unless $messageId; @@ -646,6 +631,7 @@ sub getMailFromQueue { return $class->getMail; } + #---------------------------------------------------------------------------- =head2 sessionsToDelete ( $session, [$session, ...] ) @@ -660,7 +646,7 @@ This is a class method. sub sessionsToDelete { my $class = shift; - push @guarded, cleanupGuard(@_); + $class->addToCleanup(@_); } #---------------------------------------------------------------------------- @@ -677,7 +663,7 @@ This is a class method. sub assetsToPurge { my $class = shift; - push @guarded, cleanupGuard(@_); + $class->addToCleanup(@_); } #---------------------------------------------------------------------------- @@ -693,7 +679,7 @@ This is a class method. sub groupsToDelete { my $class = shift; - push @guarded, cleanupGuard(@_); + $class->addToCleanup(@_); } @@ -710,7 +696,7 @@ This is a class method. sub storagesToDelete { my $class = shift; - push @guarded, cleanupGuard(map { + $class->addToCleanup(map { ref $_ ? $_ : ('WebGUI::Storage' => $_) } @_); } @@ -727,7 +713,7 @@ This is a class method. sub tagsToRollback { my $class = shift; - push @guarded, cleanupGuard(@_); + $class->addToCleanup(@_); } #---------------------------------------------------------------------------- @@ -743,7 +729,7 @@ This is a class method. sub usersToDelete { my $class = shift; - push @guarded, cleanupGuard(@_); + $class->addToCleanup(@_); } #---------------------------------------------------------------------------- @@ -759,7 +745,7 @@ This is a class method. sub workflowsToDelete { my $class = shift; - push @guarded, cleanupGuard(@_); + $class->addToCleanup(@_); } @@ -973,12 +959,26 @@ This is a class method. =cut +my @guarded; sub addToCleanup { shift if eval { $_[0]->isa($CLASS) }; push @guarded, cleanupGuard(@_); } +sub cleanup { + # remove guards in reverse order they were added, triggering all of the + # requested cleanup operations + pop @guarded + while @guarded; + + if ( our $SESSION ) { + $SESSION->var->end; + $SESSION->close; + undef $SESSION; + } +} + #---------------------------------------------------------------------------- =head1 BUGS From 8cd0f80bd4ebf86a51206bb78e6e3012d8174bed Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Fri, 23 Apr 2010 19:22:37 -0500 Subject: [PATCH 80/92] some documentation additions/fixes --- README | 13 ++++++++----- app.psgi | 5 ++++- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/README b/README index cec8431da..4ab9f2f19 100644 --- a/README +++ b/README @@ -9,22 +9,25 @@ To try this out: 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 .psgi file gets to set WEBGUI_ROOT and WEBGUI_CONFIG. +* 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 +* $session creates the $request WebGUI::Session::Request and $response WebGUI::Session::Response objects (one per request) - + diff --git a/app.psgi b/app.psgi index f57478db6..d03d8570c 100644 --- a/app.psgi +++ b/app.psgi @@ -9,7 +9,8 @@ builder { my $config = WebGUI::Config->new($config_file); my $psgi = $config->get('psgiFile') || WebGUI::Paths->defaultPSGI; my $app = do { - $ENV{WEBGUI_CONFIG} = $config_file; + # default psgi file uses environment variable to find config file + local $ENV{WEBGUI_CONFIG} = $config_file; Plack::Util::load_psgi($psgi); }; $first_app ||= $app; @@ -17,6 +18,8 @@ builder { mount "http://$sitename/" => $app; } } + + # use the first config found as a fallback mount '/' => $first_app; }; From 9c725aa2372dcdecef9889cf2876c23f91f10f10 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 6 May 2010 09:28:18 -0500 Subject: [PATCH 81/92] fix error handling in SQL --- lib/WebGUI/Exception.pm | 55 ++++++----------------------------------- lib/WebGUI/SQL.pm | 5 +++- 2 files changed, 11 insertions(+), 49 deletions(-) diff --git a/lib/WebGUI/Exception.pm b/lib/WebGUI/Exception.pm index 4c475bae1..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; @@ -318,13 +274,16 @@ use Exception::Class ( description => "Couldn't establish a connection.", fields => [qw{ resource }], }, - - - 'WebGUI::Error::Fatal' => { + + '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/SQL.pm b/lib/WebGUI/SQL.pm index 1bc6445a3..49bd89369 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -20,6 +20,8 @@ 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; @@ -136,7 +138,7 @@ sub connect { $params->{AutoCommit} = 1; $params->{ShowErrorStatement} = 1; $params->{HandleError} = sub { - $session->errorHandler->fatal(Carp::longmess(shift)); + WebGUI::Error::Database->throw(shift); }; if ( ($class->parse_dsn($dsn))[1] eq 'mysql' ) { $params->{mysql_enable_utf8} = 1; @@ -839,6 +841,7 @@ sub session { my $self = shift; if (@_) { $self->{private_webgui_session} = shift; + Scalar::Util::weaken $self->{private_webgui_session}; } return $self->{private_webgui_session}; } From defb78ab643deb3ad550f575e2bfdfb34a95e525 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 6 May 2010 09:31:04 -0500 Subject: [PATCH 82/92] don't use ForwardedHeaders, and different mechanism for Performance debug middleware --- sbin/testEnvironment.pl | 1 - var/site.psgi | 5 ++--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/sbin/testEnvironment.pl b/sbin/testEnvironment.pl index 265a628bf..38fd9a6ed 100755 --- a/sbin/testEnvironment.pl +++ b/sbin/testEnvironment.pl @@ -112,7 +112,6 @@ checkModule("Plack::Request"); checkModule("Plack::Response"); checkModule("Plack::Middleware::Status"); checkModule("Plack::Middleware::Debug"); -checkModule("Plack::Middleware::ForwardedHeaders"); checkModule("URI::Escape", "3.29" ); checkModule("POSIX" ); checkModule("List::Util" ); diff --git a/var/site.psgi b/var/site.psgi index 232cb562c..df738477c 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -2,13 +2,11 @@ use strict; use Plack::Builder; use Plack::App::File; use WebGUI; -use WebGUI::Middleware::Debug::Performance; builder { my $wg = WebGUI->new( site => $ENV{WEBGUI_CONFIG} ); my $config = $wg->config; - enable 'ForwardedHeaders'; enable 'Log4perl', category => $config->getFilename, conf => WebGUI::Paths->logConfig; # Reproduce URL handler functionality with middleware @@ -27,6 +25,7 @@ builder { 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', @@ -38,8 +37,8 @@ builder { [ 'MySQLTrace', skip_packages => qr/\AWebGUI::SQL(?:\z|::)/ ], 'Response', 'Logger', - sub { WebGUI::Middleware::Debug::Performance->wrap($_[0]) }, ]; + 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 { From 99386f52ebabccc74be12ac0cd480bfc0721135d Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Sun, 9 May 2010 08:32:05 -0500 Subject: [PATCH 83/92] don't preload for development, and encode output as UTF-8 --- app.psgi | 6 +++++- var/site.psgi | 5 +++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/app.psgi b/app.psgi index d03d8570c..bace19496 100644 --- a/app.psgi +++ b/app.psgi @@ -1,8 +1,12 @@ use strict; use Plack::Builder; -use WebGUI::Paths -preload; +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) { diff --git a/var/site.psgi b/var/site.psgi index df738477c..32dd72e6f 100644 --- a/var/site.psgi +++ b/var/site.psgi @@ -8,6 +8,11 @@ builder { 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'; From 8597bdbb0f7cb14a08660870efabea4ebaac7d6f Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Mon, 10 May 2010 16:40:15 -0500 Subject: [PATCH 84/92] allow undefined template or snippet text --- lib/WebGUI/Asset/Snippet.pm | 5 ++++- lib/WebGUI/Asset/Template.pm | 12 +++++++----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/lib/WebGUI/Asset/Snippet.pm b/lib/WebGUI/Asset/Snippet.pm index 8567c0ad8..bb9ce3301 100644 --- a/lib/WebGUI/Asset/Snippet.pm +++ b/lib/WebGUI/Asset/Snippet.pm @@ -53,7 +53,10 @@ property snippetPacked => ( sub _build_snippetPacked { my $self = shift; my $snippet = $self->snippet; - if ( $self->mimeType eq "text/html" ) { + if ( !defined $snippet ) { + # do nothing + } + elsif ( $self->mimeType eq "text/html" ) { HTML::Packer::minify( \$snippet, { remove_comments => 1, do_javascript => "shrink", diff --git a/lib/WebGUI/Asset/Template.pm b/lib/WebGUI/Asset/Template.pm index e8c5337eb..a58f5b8aa 100644 --- a/lib/WebGUI/Asset/Template.pm +++ b/lib/WebGUI/Asset/Template.pm @@ -80,11 +80,13 @@ property templatePacked => ( sub _build_templatePacked { my $self = shift; my $template = $self->template; - HTML::Packer::minify( \$template, { - remove_comments => 1, - do_javascript => 'shrink', - do_stylesheet => 'minify', - } ); + if (defined $template) { + HTML::Packer::minify( \$template, { + remove_comments => 1, + do_javascript => 'shrink', + do_stylesheet => 'minify', + } ); + } $template; } From fc6d8e0016361a1b8d252d7fd7a0268353b54fa4 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Mon, 10 May 2010 16:41:21 -0500 Subject: [PATCH 85/92] workaround for url mapping when request unavailable --- lib/WebGUI/Session/Url.pm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/WebGUI/Session/Url.pm b/lib/WebGUI/Session/Url.pm index c90e32390..2ad0f8e3d 100644 --- a/lib/WebGUI/Session/Url.pm +++ b/lib/WebGUI/Session/Url.pm @@ -193,6 +193,9 @@ sub gateway { sub make_urlmap_work { my $self = shift; my $url = shift; + if (! $self->session->request) { + return $url; + } my $uri = $self->session->request->base; $uri->path($uri->path . $url); my $path = $uri->path; From a80b6a5f6d147f139335889d1de1ed752a7dc54c Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Mon, 10 May 2010 16:42:03 -0500 Subject: [PATCH 86/92] proper log caller depth with no request --- lib/WebGUI/Session/ErrorHandler.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/WebGUI/Session/ErrorHandler.pm b/lib/WebGUI/Session/ErrorHandler.pm index a124dba13..89c3fc6c1 100644 --- a/lib/WebGUI/Session/ErrorHandler.pm +++ b/lib/WebGUI/Session/ErrorHandler.pm @@ -213,6 +213,7 @@ sub new { $logger = sub { my $args = shift; my $level = $args->{level}; + local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; $log4perl->$level( $args->{message} ); }; } From d75fa542315da3bcc2f9a6344c0902087939439e Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 4 Jun 2010 22:32:48 -0400 Subject: [PATCH 87/92] Preliminary PseudoRequest workarounds --- t/lib/WebGUI/Test.pm | 28 +++++++++++++++++++++------- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index 299ddc3c6..02564e864 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -139,16 +139,25 @@ If true, the session won't be registered for automatic deletion. sub newSession { my $noCleanup = shift; - my $pseudoRequest = WebGUI::PseudoRequest->new; require WebGUI::Session; - my $session = WebGUI::Session->open( $CLASS->config ); - $session->{_request} = $pseudoRequest; + my $session = WebGUI::Session->open( $CLASS->config, newEnv() ); + # my $pseudoRequest = WebGUI::PseudoRequest->new; + # $session->{_request} = $pseudoRequest; if ( ! $noCleanup ) { $CLASS->addToCleanup($session); } return $session; } +sub newEnv { + my $form = shift; + require HTTP::Message::PSGI; + require HTTP::Request::Common; + my $config = $CLASS->config; + my $url = 'http://' . $config->get('sitename'); + my $env = HTTP::Request->new( $form ? ( POST => $url, [ %$form ] ) : ( GET => $url ) )->to_psgi; + return $env; +} #---------------------------------------------------------------------------- @@ -335,7 +344,7 @@ Returns the name of the WebGUI config file used for this test. sub file { return our $CONFIG_FILE; -} +} #---------------------------------------------------------------------------- @@ -355,6 +364,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 @@ -378,9 +390,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 @@ -405,7 +418,8 @@ sub getPage { $session->user({ user => $oldUser }); # Return the page's output - return $request->get_output; + return join '', @{$session->response->body}; + } #---------------------------------------------------------------------------- From 7b9e230409607430c359bcb431bd2259233e2cd7 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 11 May 2010 20:27:24 -0500 Subject: [PATCH 88/92] improving setRow --- lib/WebGUI/SQL.pm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/lib/WebGUI/SQL.pm b/lib/WebGUI/SQL.pm index 92c5372a7..c8c824756 100644 --- a/lib/WebGUI/SQL.pm +++ b/lib/WebGUI/SQL.pm @@ -133,7 +133,7 @@ sub connect { } $params = { @params }; } - $params->{RaiseError} = 1; + $params->{RaiseError} = 0; $params->{PrintError} = 0; $params->{AutoCommit} = 1; $params->{ShowErrorStatement} = 1; @@ -157,6 +157,7 @@ sub connect { package WebGUI::SQL::db; +use Try::Tiny; our @ISA = qw(DBI::db); #------------------------------------------------------------------- @@ -879,21 +880,24 @@ sub setRow { if ($data->{$keyColumn} eq 'new' || $id) { $id ||= $self->session->id->generate; $data->{$keyColumn} = $id; - $self->do("REPLACE INTO $table ($key) VALUES (?)", {}, $id); + } + else { + $id = $data->{$keyColumn}; } - my @fields = map { $self->quote_identifier($_) . '=?' } keys %$data; - my @data = values %$data; - - if (@fields) { - $self->do( - "UPDATE $table SET " . join(", ", @fields) - . " WHERE $key = ?", - {}, - @data, - $id, - ); + 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; } From 6b1c3c88901ceae75a1f65d262ef2ba928ea6495 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Wed, 9 Jun 2010 06:57:29 -0500 Subject: [PATCH 89/92] remove useless test END blocks --- t/Account.t | 5 ----- t/Account/Friends.t | 5 ----- t/Asset/EMSSubmissionForm.t | 6 ------ t/Asset/Sku/Donation.t | 7 ------- t/Asset/Story.t | 2 -- t/Asset/Wobject/Survey/ResponseJSON.t | 3 --- t/Asset/Wobject/Survey/SurveyJSON.t | 4 ---- t/Auth/mech.t | 4 ---- t/Exception/Shop.t | 5 ----- t/Form.t | 6 ------ t/Form/DataTable.t | 5 ----- t/Form/SelectRichEditor.t | 6 ------ t/FormBuilder/Tab.t | 6 ------ t/Inbox/Message.t | 6 ------ t/Operation/AdSpace.t | 5 ----- t/Operation/Auth.t | 6 ------ t/Operation/User/service.t | 6 ------ t/Pluggable.t | 7 ------- t/Search.t | 5 ----- t/Session/ErrorHandler.t | 2 -- t/Session/Output.t | 2 -- t/Shop/PayDriver.t | 5 ----- t/Shop/PayDriver/Ogone.t | 11 ----------- t/Shop/PayDriver/PayPalStd.t | 4 ---- t/Shop/ShipDriver.t | 5 ----- t/Shop/Tax.t | 6 ------ t/Storage.t | 1 - t/Storage/Image.t | 3 --- t/Workflow/Activity/GetCsMail.t | 5 ----- t/Workflow/Activity/RecheckVATNumber.t | 7 ------- 30 files changed, 150 deletions(-) diff --git a/t/Account.t b/t/Account.t index 22d38d3ad..2cd2a29c0 100644 --- a/t/Account.t +++ b/t/Account.t @@ -68,9 +68,4 @@ is( $account->getUrl( 'op=account' ), $session->url->page( 'op=account' ), 'getUrl doesnt add op=account if already exists' ); -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Account/Friends.t b/t/Account/Friends.t index f630ae3f3..298427cf4 100644 --- a/t/Account/Friends.t +++ b/t/Account/Friends.t @@ -69,9 +69,4 @@ is( $account->getUrl( 'op=account' ), $session->url->page( 'op=account' ), 'getUrl doesnt add op=account if already exists' ); -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Asset/EMSSubmissionForm.t b/t/Asset/EMSSubmissionForm.t index 12f92c226..763b01396 100644 --- a/t/Asset/EMSSubmissionForm.t +++ b/t/Asset/EMSSubmissionForm.t @@ -507,10 +507,4 @@ $sub1->getFormattedComments; #done_testing(); #print 'press return to complete test' ; <>; -#---------------------------------------------------------------------------- -# Cleanup -END { - - -} #vim:ft=perl diff --git a/t/Asset/Sku/Donation.t b/t/Asset/Sku/Donation.t index 7e6e833d2..4d52370a7 100644 --- a/t/Asset/Sku/Donation.t +++ b/t/Asset/Sku/Donation.t @@ -53,11 +53,4 @@ is($sku->getConfiguredTitle, "Test Donation (200)", "getConfiguredTitle()"); $sku->purge; - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} - 1; diff --git a/t/Asset/Story.t b/t/Asset/Story.t index 54eaaddab..7f13fa4e1 100644 --- a/t/Asset/Story.t +++ b/t/Asset/Story.t @@ -432,5 +432,3 @@ cmp_bag( '...asset package data has the storage locations in it' ); -END { -} diff --git a/t/Asset/Wobject/Survey/ResponseJSON.t b/t/Asset/Wobject/Survey/ResponseJSON.t index 506a46651..3b31bccc2 100644 --- a/t/Asset/Wobject/Survey/ResponseJSON.t +++ b/t/Asset/Wobject/Survey/ResponseJSON.t @@ -1032,6 +1032,3 @@ sub buildSurveyJSON { return $sjson; } -#---------------------------------------------------------------------------- -# Cleanup -END { } diff --git a/t/Asset/Wobject/Survey/SurveyJSON.t b/t/Asset/Wobject/Survey/SurveyJSON.t index dd381bd55..4830b4c25 100644 --- a/t/Asset/Wobject/Survey/SurveyJSON.t +++ b/t/Asset/Wobject/Survey/SurveyJSON.t @@ -2183,7 +2183,3 @@ sub getBareSkeletons { type => 'answer', }; } - -#---------------------------------------------------------------------------- -# Cleanup -END { } diff --git a/t/Auth/mech.t b/t/Auth/mech.t index ccde88b10..dd1a80f8f 100644 --- a/t/Auth/mech.t +++ b/t/Auth/mech.t @@ -276,7 +276,3 @@ $mech->submit_form_ok( ); $mech->base_is( $assetUrl, "We don't get redirected" ); -#---------------------------------------------------------------------------- -# Cleanup -END { -} diff --git a/t/Exception/Shop.t b/t/Exception/Shop.t index 745d0f34e..4fb6fe1e4 100644 --- a/t/Exception/Shop.t +++ b/t/Exception/Shop.t @@ -45,9 +45,4 @@ $e = Exception::Class->caught; isa_ok($e, 'WebGUI::Error'); isa_ok($e, 'WebGUI::Error::Shop::RemoteShippingRate'); -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Form.t b/t/Form.t index 3acb18843..4d0848bbe 100644 --- a/t/Form.t +++ b/t/Form.t @@ -24,12 +24,6 @@ use WebGUI::Test; # Init my $session = WebGUI::Test->session; -#---------------------------------------------------------------------------- -# Cleanup -END { - -} - #---------------------------------------------------------------------------- # Tests diff --git a/t/Form/DataTable.t b/t/Form/DataTable.t index ada791856..df0bf63ec 100644 --- a/t/Form/DataTable.t +++ b/t/Form/DataTable.t @@ -120,9 +120,4 @@ like( $html, qr{]*id="test-container-table"}, "getTableHtml table has I my $html = $dt->toHtml; ok( $dt->get( "showEdit" ), "showEdit gets set by toHtml" ); -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Form/SelectRichEditor.t b/t/Form/SelectRichEditor.t index 5a8351813..d9f4e808d 100644 --- a/t/Form/SelectRichEditor.t +++ b/t/Form/SelectRichEditor.t @@ -28,12 +28,6 @@ use WebGUI::Form::SelectRichEditor; my $session = WebGUI::Test->session; my $root = WebGUI::Asset->getRoot( $session ); -#---------------------------------------------------------------------------- -# Cleanup -END { - -} - #---------------------------------------------------------------------------- # Tests plan tests => 1; diff --git a/t/FormBuilder/Tab.t b/t/FormBuilder/Tab.t index 39b949e6d..44a6a65da 100644 --- a/t/FormBuilder/Tab.t +++ b/t/FormBuilder/Tab.t @@ -46,10 +46,4 @@ is( $tab->label, 'My Label' ); is( $tab->label('New Label'), 'New Label' ); is( $tab->label, 'New Label' ); - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Inbox/Message.t b/t/Inbox/Message.t index c35c9d104..20ad3774b 100644 --- a/t/Inbox/Message.t +++ b/t/Inbox/Message.t @@ -73,10 +73,4 @@ $tempMessage->delete; } - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Operation/AdSpace.t b/t/Operation/AdSpace.t index eff95ceb3..ce35b6984 100644 --- a/t/Operation/AdSpace.t +++ b/t/Operation/AdSpace.t @@ -68,8 +68,3 @@ ok( $adSpace->get('name') eq 'oldname', 'AdSpace does not get saved.' ); $adSpace->delete; -#---------------------------------------------------------------------------- -# Cleanup -END { - -} diff --git a/t/Operation/Auth.t b/t/Operation/Auth.t index a0d5c8e34..d5c891f9c 100644 --- a/t/Operation/Auth.t +++ b/t/Operation/Auth.t @@ -55,9 +55,3 @@ unlike( "Hidden form elements for login NOT displayed to valid user", ); - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} diff --git a/t/Operation/User/service.t b/t/Operation/User/service.t index 26d89b6db..23494198c 100644 --- a/t/Operation/User/service.t +++ b/t/Operation/User/service.t @@ -454,10 +454,4 @@ cmp_deeply( ); ok( !WebGUI::User->validUserId( $session, $userRed->getId ), "UserId no longer exists" ); - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Pluggable.t b/t/Pluggable.t index bd8bf280a..01ef8273f 100644 --- a/t/Pluggable.t +++ b/t/Pluggable.t @@ -135,10 +135,3 @@ is($dumper->Dump, q|$VAR1 = { ); }; -#---------------------------------------------------------------------------- -# Cleanup - -END { - -} - diff --git a/t/Search.t b/t/Search.t index e46fdbaec..932e87560 100644 --- a/t/Search.t +++ b/t/Search.t @@ -82,9 +82,4 @@ SKIP: { cmp_deeply( $assetIds, [ $article->getId ], 'ideograph search works'); } -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Session/ErrorHandler.t b/t/Session/ErrorHandler.t index 84229a9b2..02a3b77d1 100644 --- a/t/Session/ErrorHandler.t +++ b/t/Session/ErrorHandler.t @@ -239,5 +239,3 @@ TODO: { ok(0, 'output from fatal when there is a db handler and request present'); } -END { -} diff --git a/t/Session/Output.t b/t/Session/Output.t index bf5fdde14..18c5364ef 100644 --- a/t/Session/Output.t +++ b/t/Session/Output.t @@ -68,5 +68,3 @@ SKIP: { } -END { -} diff --git a/t/Shop/PayDriver.t b/t/Shop/PayDriver.t index 362b37800..5357ab9b8 100644 --- a/t/Shop/PayDriver.t +++ b/t/Shop/PayDriver.t @@ -478,8 +478,3 @@ undef $driver; } - -#---------------------------------------------------------------------------- -# Cleanup -END { -} diff --git a/t/Shop/PayDriver/Ogone.t b/t/Shop/PayDriver/Ogone.t index ce68f5459..eb169d89e 100644 --- a/t/Shop/PayDriver/Ogone.t +++ b/t/Shop/PayDriver/Ogone.t @@ -577,16 +577,5 @@ is ($count, 0, 'delete deleted the object'); undef $driver; - - - -#---------------------------------------------------------------------------- -# Cleanup - - - -} -END { - } #vim:ft=perl diff --git a/t/Shop/PayDriver/PayPalStd.t b/t/Shop/PayDriver/PayPalStd.t index fd8287c92..14387d74c 100644 --- a/t/Shop/PayDriver/PayPalStd.t +++ b/t/Shop/PayDriver/PayPalStd.t @@ -79,7 +79,3 @@ undef $driver; } -#---------------------------------------------------------------------------- -# Cleanup -END { -} diff --git a/t/Shop/ShipDriver.t b/t/Shop/ShipDriver.t index 6e9be7cad..6650a66c7 100644 --- a/t/Shop/ShipDriver.t +++ b/t/Shop/ShipDriver.t @@ -401,8 +401,3 @@ undef $driver; } - -#---------------------------------------------------------------------------- -# Cleanup -END { -} diff --git a/t/Shop/Tax.t b/t/Shop/Tax.t index 3149055bb..e5f1494b0 100644 --- a/t/Shop/Tax.t +++ b/t/Shop/Tax.t @@ -126,10 +126,4 @@ SKIP: { } } - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Storage.t b/t/Storage.t index 60efc6453..7f6647766 100644 --- a/t/Storage.t +++ b/t/Storage.t @@ -15,7 +15,6 @@ use lib "$FindBin::Bin/lib"; use WebGUI::Test; use WebGUI::Session; use WebGUI::Storage; -use WebGUI::PseudoRequest; use File::Spec; use File::Temp qw/tempdir/; diff --git a/t/Storage/Image.t b/t/Storage/Image.t index 4a04d5bcd..050e8c98d 100644 --- a/t/Storage/Image.t +++ b/t/Storage/Image.t @@ -281,6 +281,3 @@ TODO: { local $TODO = "Methods that need to be tested"; ok(0, 'resize'); } - -END { -} diff --git a/t/Workflow/Activity/GetCsMail.t b/t/Workflow/Activity/GetCsMail.t index da874f98d..2bba5d725 100644 --- a/t/Workflow/Activity/GetCsMail.t +++ b/t/Workflow/Activity/GetCsMail.t @@ -143,9 +143,4 @@ $post2mock->set_always('getId', $post2_id); WebGUI::Test->unmockAssetId($post_id); } -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl diff --git a/t/Workflow/Activity/RecheckVATNumber.t b/t/Workflow/Activity/RecheckVATNumber.t index 04d2d6010..7f73bf065 100644 --- a/t/Workflow/Activity/RecheckVATNumber.t +++ b/t/Workflow/Activity/RecheckVATNumber.t @@ -110,11 +110,4 @@ sub createInstance { return $instance; }; - - -#---------------------------------------------------------------------------- -# Cleanup -END { - -} #vim:ft=perl From 883b145c44e18a12d1b249459356776a1bb8cf8f Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Wed, 9 Jun 2010 07:03:49 -0500 Subject: [PATCH 90/92] some WebGUI::Test cleanups --- t/lib/WebGUI/Test.pm | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index f0a417b9f..085ceb837 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -39,6 +39,7 @@ use List::MoreUtils qw( any ); use Carp qw( carp croak ); use JSON qw( from_json to_json ); use Scope::Guard; +use Try::Tiny; use WebGUI::Paths -inc; our $WEBGUI_TEST_ROOT = File::Spec->catdir( @@ -141,8 +142,6 @@ sub newSession { my $noCleanup = shift; require WebGUI::Session; my $session = WebGUI::Session->open( $CLASS->config, newEnv() ); - # my $pseudoRequest = WebGUI::PseudoRequest->new; - # $session->{_request} = $pseudoRequest; if ( ! $noCleanup ) { $CLASS->addToCleanup($session); } @@ -154,11 +153,24 @@ sub newEnv { require HTTP::Message::PSGI; require HTTP::Request::Common; my $config = $CLASS->config; - my $url = 'http://' . $config->get('sitename'); + my $url = 'http://' . $config->get('sitename')->[0]; my $env = HTTP::Request->new( $form ? ( POST => $url, [ %$form ] ) : ( GET => $url ) )->to_psgi; return $env; } +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 mockAssetId ( $assetId, $object ) @@ -419,7 +431,6 @@ sub getPage { # Return the page's output return join '', @{$session->response->body}; - } #---------------------------------------------------------------------------- @@ -841,7 +852,14 @@ Example call: }, 'SQL' => sub { my (undef, $sql) = @_; - return $CLASS->session->db->dbh->prepare($sql); + my $db = $CLASS->session->db; + my @params; + if ( ref $sql ) { + ( $sql, @params ) = @$sql; + } + return sub { + $db->do( $sql, {}, @params ); + } }, ); @@ -922,7 +940,9 @@ Example call: 'CODE' => sub { (shift)->(); }, - 'SQL' => 'execute', + 'SQL' => sub { + (shift)->(); + }, ); sub cleanupGuard { @@ -1007,7 +1027,7 @@ This is a class method. my @guarded; sub addToCleanup { shift - if eval { $_[0]->isa($CLASS) }; + if try { $_[0]->isa($CLASS) }; push @guarded, cleanupGuard(@_); } @@ -1030,13 +1050,4 @@ sub cleanup { } } -#---------------------------------------------------------------------------- - -=head1 BUGS - -When trying to load the APR module, perl invariably throws an Out Of Memory -error. For this reason, getPage disables header processing. - -=cut - 1; From 169218abf7de681325eee12f3ea998ca0e9ee198 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 10 Jun 2010 08:17:17 -0500 Subject: [PATCH 91/92] fix mistake in WebGUI::Test --- t/lib/WebGUI/Test.pm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index 085ceb837..966be7a4c 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -139,6 +139,8 @@ If true, the session won't be registered for automatic deletion. =cut sub newSession { + shift + if eval { $_[0]->isa($CLASS) }; my $noCleanup = shift; require WebGUI::Session; my $session = WebGUI::Session->open( $CLASS->config, newEnv() ); @@ -149,7 +151,10 @@ sub newSession { } sub newEnv { + shift + if eval { $_[0]->isa($CLASS) }; my $form = shift; + require HTTP::Message::PSGI; require HTTP::Request::Common; my $config = $CLASS->config; @@ -1027,7 +1032,7 @@ This is a class method. my @guarded; sub addToCleanup { shift - if try { $_[0]->isa($CLASS) }; + if eval { $_[0]->isa($CLASS) }; push @guarded, cleanupGuard(@_); } From e063818e2d90b819d1f3e5c7b0fa28d0af7d035c Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 10 Jun 2010 08:18:43 -0500 Subject: [PATCH 92/92] some URL fixes and removing some uses of PseudoRequest --- lib/WebGUI/Session/Url.pm | 9 ++--- t/Asset/AssetExportHtml.t | 1 - t/Auth.t | 34 ++++++------------- t/Session/Url.t | 70 +++++++++++++++------------------------ t/lib/WebGUI/Test.pm | 24 +++++++++++--- 5 files changed, 62 insertions(+), 76 deletions(-) diff --git a/lib/WebGUI/Session/Url.pm b/lib/WebGUI/Session/Url.pm index 2ad0f8e3d..1b5fc6902 100644 --- a/lib/WebGUI/Session/Url.pm +++ b/lib/WebGUI/Session/Url.pm @@ -196,11 +196,12 @@ sub make_urlmap_work { if (! $self->session->request) { return $url; } - my $uri = $self->session->request->base; + if (URI->new($url, 'http')->host) { + return $url; + } + my $uri = $self->session->request->base; $uri->path($uri->path . $url); - my $path = $uri->path; - $path =~ s{^//}{/}; - return $path; + return $uri->path; } #------------------------------------------------------------------- diff --git a/t/Asset/AssetExportHtml.t b/t/Asset/AssetExportHtml.t index 7d6acfdc3..a0c498ea4 100644 --- a/t/Asset/AssetExportHtml.t +++ b/t/Asset/AssetExportHtml.t @@ -17,7 +17,6 @@ use strict; use lib "$FindBin::Bin/../lib"; use Test::More; use WebGUI::Test; # Must use this before any other WebGUI modules -use WebGUI::PseudoRequest; use WebGUI::Session; use WebGUI::Asset; 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/Session/Url.t b/t/Session/Url.t index d44eb9a0d..46a6dedf0 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 966be7a4c..071dd86d5 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -128,7 +128,7 @@ END { #---------------------------------------------------------------------------- -=head2 newSession ( $noCleanup ) +=head2 newSession ( $noCleanup, [ $request ] ) Builds a WebGUI session object for testing. @@ -136,14 +136,19 @@ 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 $request = shift; require WebGUI::Session; - my $session = WebGUI::Session->open( $CLASS->config, newEnv() ); + my $session = WebGUI::Session->open( $CLASS->config, newEnv( $request ) ); if ( ! $noCleanup ) { $CLASS->addToCleanup($session); } @@ -158,9 +163,18 @@ sub newEnv { require HTTP::Message::PSGI; require HTTP::Request::Common; my $config = $CLASS->config; - my $url = 'http://' . $config->get('sitename')->[0]; - my $env = HTTP::Request->new( $form ? ( POST => $url, [ %$form ] ) : ( GET => $url ) )->to_psgi; - return $env; + 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 (&) {