From 484760bef0163e5f0048678457461caa5eb168aa Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 18:54:54 +1100 Subject: [PATCH] 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;