fixed cookie handling
This commit is contained in:
Patrick Donelan
parent
484760bef0
commit
b4698f7725
3 changed files with 99 additions and 74 deletions
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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(@_);
|
||||
}
|
||||
|
||||
################################################
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue