Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

clean code; psgi support

  • Loading branch information...
commit e8b7f98d347447f1696a52c962ed5c9c4d5af40f 1 parent d37dc5c
zag authored
View
133 lib/WebDAO/CV.pm
@@ -1,6 +1,6 @@
#===============================================================================
#
-# DESCRIPTION: CGI controller
+# DESCRIPTION: controller
#
# AUTHOR: Aliaksandr P. Zahatski, <zahatski@gmail.com>
#===============================================================================
@@ -10,6 +10,7 @@ use URI;
use Data::Dumper;
use strict;
use warnings;
+use HTTP::Body;
use WebDAO::Base;
use base qw( WebDAO::Base );
@@ -43,9 +44,9 @@ sub url {
( $env->{PATH_INFO}, $env->{QUERY_STRING} ) =
$env->{REQUEST_URI} =~ /([^?]*)(?:\?(.*)$)?/s;
}
- my $path = $env->{PATH_INFO}; # 'PATH_INFO' => '/Env'
- my $host = $env->{HTTP_HOST}; # 'HTTP_HOST' => '127.0.0.1:5000'
- my $query = $env->{QUERY_STRING}; # 'QUERY_STRING' => '434=34&erer=2'
+ my $path = $env->{PATH_INFO} || ''; # 'PATH_INFO' => '/Env'
+ my $host = $env->{HTTP_HOST} || 'example.org'; # 'HTTP_HOST' => '127.0.0.1:5000'
+ my $query = $env->{QUERY_STRING}|| ''; # 'QUERY_STRING' => '434=34&erer=2'
my $proto = $env->{'psgi.url_scheme'} || 'http';
my $full_path = "$proto://${host}${path}?$query";
@@ -95,15 +96,93 @@ sub accept {
=head2 param
-return params (currently only from GET)
+return params
=cut
sub param {
my $self = shift;
- my $params = { $self->url()->query_form };
+ my $params = $self->{parsed_params};
+ unless ($params) {
+ #init by POST params
+ $params = $self->_parse_body;
+ my @get_params = $self->url()->query_form;
+ while (my ($k, $v) = splice(@get_params,0,2 )) {
+ unless ( exists $params->{ $k } ) {
+ $params->{ $k } = $v
+ } else {
+ my $val = $params->{ $k };
+ #if array ?
+ if ( ref $val ) {
+ push @$val, $v
+ } else {
+ $params->{ $k } = [$val, ref($v) ? @$v : $v]
+ }
+ }
+ }
+ $self->{parsed_params} = $params;
+ }
return keys %$params unless @_;
- return $params->{$_[0]};
+ return undef unless exists $params->{$_[0]};
+ my $res = $params->{$_[0]};
+ if ( ref($res) ) {
+ return wantarray ? @$res : $res->[0]
+ }
+ return $res;
+}
+
+#parse body
+sub _parse_body {
+ my $self = shift;
+
+ my $content_type = $self->{env}->{CONTENT_TYPE};
+ my $content_length = $self->{env}->{CONTENT_LENGTH};
+ if (!$content_type && !$content_length) {
+ return {};
+ }
+
+ my $body = HTTP::Body->new($content_type, $content_length);
+ $body->cleanup(1);
+
+ my $input = $self->{env}->{'psgi.input'};
+ #reset IO
+ $input->seek(0,0);
+ my $spin = 0;
+
+ while ($content_length) {
+ $input->read(my $chunk, $content_length < 8192 ? $content_length : 8192);
+ my $read = length $chunk;
+ $content_length -= $read;
+ $body->add($chunk);
+ if ($read == 0 && $spin++ > 2000) {
+ Carp::croak "Bad Content-Length: maybe client disconnect? ($content_length bytes remaining)";
+ }
+ }
+ $self->{'http.body'} = $body;
+ return $body->param
+}
+
+=head2 get-body
+
+Return HTTP body <FH>
+
+ my $body;
+ {
+ local $/;
+ my $fd = $r->get_request->get_body;
+ $body = <$fd>;
+ }
+
+=cut
+
+sub get_body {
+ my $self = shift;
+ unless ( exists $self->{'http.body'} ) {
+ $self->_parse_body();
+ }
+
+ my $http_body = $self->{'http.body'} || return undef;
+ return $http_body->body;
}
=head2 set_header
@@ -138,10 +217,30 @@ sub print_headers {
if ( my $cookies = $self->{headers}->{"Set-Cookie"} ) {
push @{ $headers{"Set-Cookie"} }, @$cookies;
}
+ my @cookies_headers = ();
#format cookies
- if ( my $c = delete )
+ if ( my $cookies = delete $headers{"Set-Cookie"} ) {
+ foreach my $c ( @$cookies ) {
+ my $hvalue;
+ if (ref($c) eq 'HASH') {
+ my $path = $c->{path} || '/';
+# Set-Cookie: srote=ewe&1&1&2; path=$path
+ $hvalue = "$c->{name}=$c->{value}; path=$path";
+ if (my $expires = $c->{expires}) {
+ my @MON = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
+ my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
+ my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires);
+ $year += 1900;
+ $expires = sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
+ $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
+ $hvalue .=" ;expires=$expires";
+ }
+ } else { $hvalue = $c }
+ push @cookies_headers, "Set-Cookie", $hvalue;
+ }
+ }
my $status = $self->status;
- my $fd = $self->{writer}->([$status||"200", [%headers], undef]);
+ my $fd = $self->{writer}->([$status||"200", [%headers, @cookies_headers], undef]);
$self->{fd} = $fd;
}
@@ -157,6 +256,22 @@ sub print {
}
}
+=head2 get_cookie
+
+return hashref to {key=>value}
+
+=cut
+
+sub get_cookie {
+ my $self = shift;
+ my $str = $self->{env}->{HTTP_COOKIE} || return {};
+ my %res;
+ %res =
+ map { URI::Escape::uri_unescape($_) } map { split /=/ } split /\s*[;]\s*/,
+ $str;
+ \%res;
+}
+
1;
View
144 lib/WebDAO/Response.pm
@@ -6,9 +6,13 @@ package WebDAO::Response;
WebDAO::Response - Response class
+=head1 SYNOPSYS
+
+ new WebDAO::Response:: cv => $cv
+
=head1 DESCRIPTION
-Class for set response headers
+Class for make HTTP response
=cut
@@ -18,9 +22,21 @@ use IO::File;
use DateTime;
use DateTime::Format::HTTP;
use base qw( WebDAO::Base );
-__PACKAGE__->attributes
- qw/ __session _headers _is_headers_printed _cv_obj _is_file_send _is_need_close_fh __fh _is_flushed _call_backs _is_modal /;
-__PACKAGE__->mk_attr( _forced_want_format => undef, _is_empty=>0 );
+
+__PACKAGE__->mk_attr(
+ _headers => undef,
+ _is_headers_printed =>0,
+ _cv_obj => undef,
+ _is_file_send => 0,
+ _is_need_close_fh => 0,
+ __fh => undef,
+ _is_flushed => 0,
+ _call_backs => undef,
+ _is_modal => 0,
+ _forced_want_format => undef,
+ _is_empty=>0,
+ status => 200 #default HTTP status
+ );
use strict;
@@ -39,16 +55,43 @@ sub init {
$self->_headers( {} );
$self->_call_backs( [] );
$self->_cv_obj( $par{cv} );
- $self->__session( $par{session} );
return 1;
}
+=head2 get_request
+
+Return ref to request object (WebDAO::CV)
+
+=cut
+
+sub get_request {
+ my $self = shift;
+ return $self->_cv_obj;
+}
+
+=head2 set_status INT
+
+set response HTTP status
+
+ $r->set_status(200)
+
+return C<$self>
+
+=cut
+
+sub set_status {
+ my $self = shift;
+ $self->status(@_);
+ $self
+}
+
+
=head2 set_header NAME, VALUE
Set out header:
$response->set_header('Location', $redirect_url);
- $response->set_header( -type => 'text/html; charset=utf-8' );
+ $response->set_header( 'Content-Type' => 'text/html; charset=utf-8' );
return $self reference
@@ -56,10 +99,31 @@ return $self reference
sub set_header {
my ( $self, $name, $par ) = @_;
- $self->_headers->{ uc $name } = $par;
+ #translate CGI headers
+ if ( $name =~ /^-/) {
+ my $UKey = uc $name;
+
+ if ( $UKey eq '-STATUS' ) {
+ my ($status) = $par =~ m/(\d+)/;
+ $self->status($status);
+ return; #don't save status
+ }
+ warn "Deprecated header name $name !";
+# use CGI;
+# my $h = CGI->new->header( $UKey, $par );
+# $h =~ s/\015\012//g;
+# ( $name, $par ) = split( /\s*:\s*/, $h );
+ } elsif ( $name eq 'Set-Cookie') {
+ push @{ $self->_headers->{ $name } }, $par;
+ return $self
+ }
+
+ $self->_headers->{ $name } = $par;
$self;
}
+
+
=head2 get_header NAME
return value for header NAME:
@@ -68,7 +132,7 @@ return value for header NAME:
sub get_header {
my ( $self, $name ) = @_;
- return $self->_headers->{ uc $name };
+ return $self->_headers->{ $name };
}
=head2 aliases for headers
@@ -159,47 +223,39 @@ sub print_header {
my $self = shift;
my $pnted = $self->_is_headers_printed;
return $self if $pnted;
- my $res = { data => '' }; #need for cv->response
- my $cv = $self->_cv_obj;
- my $headers = $self->_headers;
- $headers->{-TYPE} = $res->{type} if $res->{type}; #deprecated
- while ( my ( $key, $val ) = each %$headers ) {
- my $UKey = uc $key;
- $res->{headers}->{$UKey} = $headers->{$UKey}
- unless exists $res->{headers}->{$UKey};
- }
- $cv->response($res);
+ my $cv = $self->get_request;
+ $cv->status($self->status);
+ $cv->print_headers(%{ $self->_headers });
$self->_is_headers_printed(1);
$self;
}
-=head2 redirect2url <url for redirect to>
+=head2 redirect2url <url for redirect to> [, $code]
Set headers for redirect to url.return $self reference
=cut
sub redirect2url {
- my ( $self, $redirect_url ) = @_;
- $self->set_modal->set_header( "-status", '302 Found' );
- $self->set_header( '-Location', $redirect_url );
+ my ( $self, $redirect_url, $code ) = @_;
+ $self->set_modal->set_status( $code || 302 );
+ $self->set_header( 'Location', $redirect_url );
}
-=head2 set_cookie ( -name => <name>, ...)
+=head2 set_cookie ( name => <cookie_name>, value=><cookie_value> ...)
-Set cookie. For params see manpage for CGI::cookie.
+Set cookie.
return $self reference
=cut
sub set_cookie {
my $self = shift;
- my $res = $self->get_header( -cookie ) || [];
- my $cv = $self->_cv_obj;
- push @$res, $cv->cookie(@_);
- return $self->set_header( -cookie => $res );
+ $self->set_header("Set-Cookie", { @_ });
+ $self;
}
+
=head2 set_callback(sub1{}[, sub2{} ..])
Set callbacks for call after flush
@@ -242,21 +298,21 @@ sub send_file {
#set file headers
my ( $size, $mtime ) = ( stat $file_handle )[ 7, 9 ];
- $self->set_header( '-Content_length', $size );
+ $self->content_length( $size );
my $formated =
DateTime::Format::HTTP->format_datetime(
DateTime->from_epoch( epoch => $mtime ) );
- $self->set_header( '-Last-Modified', $formated );
+ $self->set_header( 'Last-Modified', $formated );
#Determine mime tape of file
if ( my $predefined = $args{-type} ) {
- $self->set_header( -type => $predefined );
+ $self->content_type( $predefined );
}
else {
##
if ($file_name) {
- $self->set_header(
- -type => $self->get_mime_for_filename($file_name) );
+ $self->content_type(
+ $self->get_mime_for_filename($file_name) );
}
}
@@ -267,7 +323,7 @@ sub send_file {
sub print {
my $self = shift;
- my $cv = $self->_cv_obj;
+ my $cv = $self->get_request;
$self->print_header;
$cv->print(@_);
return $self;
@@ -293,7 +349,7 @@ sub flush {
#do self print file
if ( $self->_is_file_send ) {
my $fd = $self->__fh;
- $self->_cv_obj->print(<$fd>);
+ $self->get_request->print(<$fd>);
close($fd) if $self->_is_need_close_fh;
}
$self->_is_flushed(1);
@@ -329,7 +385,7 @@ Set HTTP 404 headers
sub error404 {
my $self = shift;
- $self->set_modal->set_header( "-status", '404 Not Found' );
+ $self->set_modal->set_status(404);
$self->print(@_) if @_;
return $self;
}
@@ -362,11 +418,11 @@ sub set_json {
sub _destroy {
my $self = shift;
$self->{__html} = undef;
-
- # $self->_headers( {} );
- # $self->_call_backs( [] );
- # $self->_cv_obj( undef );
- $self->__session(undef);
+ #destroy called from Engine::execute2
+ # destroy tests by cleared _cv_obj
+# $self->_cv_obj( undef );
+ $self->_headers( {} );
+ $self->_call_backs( [] );
}
=head2 wantformat ['format',['forse_set_format']]
@@ -398,7 +454,7 @@ sub wantformat {
my $desired = $self->_forced_want_format();
my $default =
$desired
- || $self->detect_wantformat( $self->__session )
+ || $self->detect_wantformat( $self->get_request ) #call with CV object
|| 'html';
if ( scalar(@_) == 1 ) {
return $default eq shift;
@@ -406,7 +462,7 @@ sub wantformat {
return $default;
}
-=head2 detect_wantformat ($session)
+=head2 detect_wantformat ($cv)
Method for detect output format when C<wantformat()> called
@@ -452,7 +508,7 @@ Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
-Copyright 2002-2010 by Zahatski Aliaksandr
+Copyright 2002-2012 by Zahatski Aliaksandr
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
View
81 lib/WebDAO/Response0.pm
@@ -1,81 +0,0 @@
-#===============================================================================
-#
-# DESCRIPTION: Refacred Response object
-#
-# AUTHOR: Aliaksandr P. Zahatski, <zahatski@gmail.com>
-#===============================================================================
-#$Id$
-package WebDAO::Response0;
-use strict;
-use warnings;
-use base 'WebDAO::Response';
-
-__PACKAGE__->mk_attr( status => 200 );
-
-=head2 set_header NAME, VALUE
-
-Set out header:
-
- $response->set_header('Location', $redirect_url);
- $response->set_header( -type => 'text/html; charset=utf-8' );
-
-return $self reference
-
-=cut
-
-sub set_header {
- my ( $self, $name, $par ) = @_;
- #translate CGI headers
- if ( $name =~ /^-/) {
- my $UKey = uc $name;
-
- if ( $UKey eq '-STATUS' ) {
- my ($status) = $par =~ m/(\d+)/;
- $self->status($status);
- return; #don't save status
- }
-
- use CGI;
- my $h = CGI->new->header( $UKey, $par );
- $h =~ s/\015\012//g;
- ( $name, $par ) = split( /\s*:\s*/, $h );
- } elsif ( $name eq 'Set-Cookie') {
- push @{ $self->_headers->{ $name } }, $par;
- return $self
- }
-
- $self->_headers->{ $name } = $par;
- $self;
-}
-
-=head2 print_header
-
-print header.return $self reference
-
-=cut
-
-sub print_header {
- my $self = shift;
- my $pnted = $self->_is_headers_printed;
- return $self if $pnted;
- my $cv = $self->_cv_obj;
- $cv->status($self->status);
- $cv->print_headers(%{ $self->_headers });
- $self->_is_headers_printed(1);
- $self;
-}
-
-=head2 set_cookie ( -name => <name>, ...)
-
-Set cookie. For params see manpage for CGI::cookie.
-return $self reference
-
-=cut
-
-sub set_cookie {
- my $self = shift;
- $self->set_header("Set-Cookie", $_) for @_;
-}
-
-1;
-
View
146 lib/WebDAO/Session.pm
@@ -13,15 +13,28 @@ Session interface to device(HTTP protocol) specific function
use WebDAO::Base;
-use WebDAO::CVcgi;
+use WebDAO::CV;
use WebDAO::Store::Abstract;
use WebDAO::Response;
use Data::Dumper;
use base qw( WebDAO::Base );
use Encode qw(encode decode is_utf8);
use strict;
-__PACKAGE__->attributes
- qw( Cgi_obj Cgi_env U_id Header Params _store_obj _response_obj _is_absolute_url _request_method);
+
+__PACKAGE__->mk_attr(
+ Cgi_obj => undef, # request object
+ Cgi_env => undef,
+ U_id=> undef,
+ Params => undef,
+ _store_obj =>undef,
+ _response_obj=> undef, #deprecated ?
+ _is_absolute_url =>undef #deprecated ?
+);
+
+#sub new {
+# my $class = shift;
+# bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
+#}
sub _init {
my $self = shift;
@@ -35,24 +48,17 @@ sub Init {
#Parametrs is realm
my $self = shift;
my %args = @_;
- Header $self ( {} );
U_id $self undef;
Cgi_obj $self $args{cv}
- || new WebDAO::CVcgi::; #create default controller
+ || new WebDAO::CV::; #create default controller
my $cv = $self->Cgi_obj; # Store Cgi_obj in local var
#create response object
$self->_response_obj(
new WebDAO::Response::
- session => $self,
cv => $cv
);
_store_obj $self ( $args{store} || new WebDAO::Store::Abstract:: );
- #workaround for CGI.pm: http://rt.cpan.org/Ticket/Display.html?id=36435
- my %accept = ();
- if ( $cv->http('accept') ) {
- %accept = map { $_ => $cv->Accept($_) } $cv->Accept();
- }
Cgi_env $self (
{
url => $cv->url( -base => 1 ), #http://eng.zag
@@ -60,25 +66,36 @@ sub Init {
path_info_elments => [],
file => "",
base_url => $cv->url( -base => 1 ), #http://base.com
- query_string => $cv->query_string, #???
- referer => $cv->referer(),
- accept => \%accept
+ accept => $cv->accept,
}
);
- #fix CGI.pm bug http://rt.cpan.org/Ticket/Display.html?id=25908
- $self->Cgi_env->{path_info} =~ s/\?.*//s;
$self->get_id;
Params $self ( $self->_get_params() );
$self->Cgi_env->{path_info_elments} =
[ grep { defined $_ } split( /\//, $self->Cgi_env->{path_info} ) ];
- #save request method
- $self->request_method($ENV{REQUEST_METHOD});
#set default header
- $cv->set_header( -type => 'text/html; charset=utf-8' );
+ $cv->set_header("Content-Type" => 'text/html; charset=utf-8');
+}
+
+#Get cgi params;
+sub _get_params {
+ my $self = shift;
+ my $_cgi = $self->Cgi_obj();
+ my %params;
+ foreach my $i ( $_cgi->param() ) {
+ my @all = $_cgi->param($i);
+ foreach my $value (@all) {
+ next if ref $value;
+ $value = decode( 'utf8', $value ) unless is_utf8($value);
+ }
+ $params{$i} = scalar @all > 1 ? \@all : $all[0];
+ }
+ return \%params;
}
+
#Can be overlap if you choose another
#alghoritm generate unique session ID (i.e cookie,http_auth)
sub get_id {
@@ -132,48 +149,15 @@ sub flush_session {
$self->_store_obj->flush( $self->get_id() );
}
-sub response_obj {
+sub get_request {
my $self = shift;
- return $self->_response_obj;
-}
-
-#Session interface to device(HTTP protocol) specific function
-#$self->__send_event__("_sess_servise",{
-# funct => geturl,
-# par => $ref,
-# result => \$res
-#});
-
-#deprecated
-sub sess_servise {
- my ( $self, $event_name, $par ) = @_;
- my %service = (
- getsess => sub { return $self },
- );
- if ( exists( $service{ $par->{funct} } ) ) {
- ${ $par->{result} } = $service{ $par->{funct} }->( $par->{par} );
- }
- else {
- logmsgs $self "not exist request funct !" . $par->{funct};
- }
+ return $self->Cgi_obj;
}
-sub response {
+#deprecated ??? use WebDAO::Engine::response
+sub response_obj {
my $self = shift;
- my $res = shift;
-
- # unless $res->type
- return if $res->{cleared};
- my $headers = $self->Header();
- $headers->{-TYPE} = $res->{type} if $res->{type};
- while ( my ( $key, $val ) = each %$headers ) {
- my $UKey = uc $key;
- $res->{headers}->{$UKey} = $headers->{$UKey}
- unless exists $res->{headers}->{$UKey};
- }
-
- # $res->{headers} = $headers;
- $self->Cgi_obj->response($res);
+ return $self->_response_obj;
}
sub print {
@@ -191,52 +175,6 @@ sub ExecEngine {
$self->flush_session();
}
-#for setup Output headers
-sub set_header {
- my $self = shift;
- my $response = $self->response_obj;
- return $self->response_obj->set_header(@_)
-
-}
-
-#Get cgi params;
-sub _get_params {
- my $self = shift;
- my $_cgi = $self->Cgi_obj();
- my %params;
- foreach my $i ( $_cgi->param() ) {
- my @all = $_cgi->param($i);
- foreach my $value (@all) {
- next if ref $value;
- $value = decode( 'utf8', $value ) unless is_utf8($value);
- }
- $params{$i} = scalar @all > 1 ? \@all : $all[0];
- }
- return \%params;
-}
-
-sub print_header() {
- my ($self) = @_;
- my $_cgi = $self->Cgi_obj();
- my $ref = $self->Header();
- return $self->response( { data => '', } );
- return $_cgi->header( map { $_ => $ref->{$_} } keys %{ $self->Header() } );
-}
-
-=head2 request_method
-
-return Req Method [GET, POST, DELETE, PUT ]
-
-=cut
-
-sub request_method {
- my $self = shift;
- if (@_) {
- $self->_request_method( shift );
- }
- $self->_request_method()
-}
-
sub destroy {
my $self = shift;
$self->_response_obj(undef);
@@ -254,7 +192,7 @@ Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
-Copyright 2002-2010 by Zahatski Aliaksandr
+Copyright 2002-2012 by Zahatski Aliaksandr
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
View
84 lib/WebDAO/Session0.pm
@@ -1,84 +0,0 @@
-#===============================================================================
-#
-# DESCRIPTION: Session0 module. Cleaned api
-#
-# AUTHOR: Aliaksandr P. Zahatski, <zahatski@gmail.com>
-#===============================================================================
-#$Id$
-package WebDAO::Session0;
-use strict;
-use warnings;
-use Encode qw(encode decode is_utf8);
-use WebDAO::Session;
-use base qw( WebDAO::Session );
-use WebDAO::CV;
-use WebDAO::Response0;
-
-#sub new {
-# my $class = shift;
-# bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
-#}
-
-#Need to be forever called from over classes;
-sub Init {
-
- #Parametrs is realm
- my $self = shift;
- my %args = @_;
- Header $self ( {} );
- U_id $self undef;
- Cgi_obj $self $args{cv}
- || new WebDAO::CV::; #create default controller
- my $cv = $self->Cgi_obj; # Store Cgi_obj in local var
- #create response object
- $self->_response_obj(
- new WebDAO::Response0::
- session => $self,
- cv => $cv
- );
- _store_obj $self ( $args{store} || new WebDAO::Store::Abstract:: );
-
- Cgi_env $self (
- {
- url => $cv->url( -base => 1 ), #http://eng.zag
- path_info => $cv->url( -absolute => 1, -path_info => 1 ),
- path_info_elments => [],
- file => "",
- base_url => $cv->url( -base => 1 ), #http://base.com
-# query_string => $cv->query_string, #???
-# referer => $cv->referer(),
- accept => $cv->accept,
- }
- );
-
- #fix CGI.pm bug http://rt.cpan.org/Ticket/Display.html?id=25908
- $self->Cgi_env->{path_info} =~ s/\?.*//s;
- $self->get_id;
- Params $self ( $self->_get_params() );
- $self->Cgi_env->{path_info_elments} =
- [ grep { defined $_ } split( /\//, $self->Cgi_env->{path_info} ) ];
- #save request method
- $self->request_method($cv->method);
- #set default header
- $cv->set_header("Content-Type" => 'text/html; charset=utf-8');
-}
-
-#Get cgi params;
-sub _get_params {
- my $self = shift;
- my $_cgi = $self->Cgi_obj();
- my %params;
- foreach my $i ( $_cgi->param() ) {
- my @all = $_cgi->param($i);
- foreach my $value (@all) {
- next if ref $value;
- $value = decode( 'utf8', $value ) unless is_utf8($value);
- }
- $params{$i} = scalar @all > 1 ? \@all : $all[0];
- }
- return \%params;
-}
-
-
-1;
-
View
53 lib/WebDAO/Test.pm
@@ -270,22 +270,63 @@ sub get_session {
1;
+sub make_cv {
+ my %args = @_;
+ my $out;
+ my $cv = WebDAO::CV->new(
+ env => $args{env},
+ writer => sub {
+ new Test::Writer::
+ out => \$out,
+ status => $_[0]->[0],
+ headers => $_[0]->[1];
+ }
+ );
+
+}
+
+package Test::Writer;
+use warnings;
+use strict;
+sub new {
+ my $class = shift;
+ my $self = bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
+}
+sub write {
+ ${ $_[0]->{out} } .= $_[1] ;
+ }
+sub close { }
+sub headers { return $_[0]->{headers} }
+
+1;
+
package TestCV;
use strict;
use warnings;
-use WebDAO::CVcgi;
-use base 'WebDAO::CVcgi';
+use WebDAO::CV;
+use base 'WebDAO::CV';
+sub new {
+ my $self = shift;
+ my $buf_ref = shift;
+ my $writer = sub {
+ new Test::Writer::
+ out => $buf_ref,
+ status => $_[0]->[0],
+ headers => $_[0]->[1];
+ };
+ $self->SUPER::new(writer=>$writer, @_ )
+}
# for skip headers
# $cv{SKIP_HEADERS} = 1
-sub _init {
+sub _init__ {
my $self = shift;
- $self->{ctr} = shift;
+ my $buf_ref = shift;
return $self->SUPER::_init(@_);
}
-sub response {
+sub response__ {
my $self = shift;
my $res = shift || return;
unless ( exists( $self->{SKIP_HEADERS} ) ) {
@@ -295,7 +336,7 @@ sub response {
}
}
-sub print {
+sub print__ {
my $self = shift;
my $out_ref = $self->{ctr};
if ( grep { ! defined $_} @_ ) {
View
30 script/webdao.psgi
@@ -12,15 +12,16 @@ use warnings;
use WebDAO::Util;
use WebDAO;
use WebDAO::CV;
+use WebDAO::Lex;
my $handler = sub {
my $env = shift;
die "Only psgi.streaming=1 servers supported !"
- unless $env->{'psgi.streaming'};
+ unless $env->{'psgi.streaming'};
my $coderef = shift;
$env->{wdEnginePar} = $ENV{wdEnginePar} || $env->{HTTP_WDENGINEPAR} ;
$env->{wdEngine} = $ENV{wdEngine} || $env->{HTTP_WDENGINE} ;
- $env->{wdSession} = $ENV{wdSession} || $env->{HTTP_WDSESSION} || 'WebDAO::Session0' ;
+ $env->{wdSession} = $ENV{wdSession} || $env->{HTTP_WDSESSION} || 'WebDAO::Session' ;
my $ini = WebDAO::Util::get_classes(__env => $env, __preload=>1);
my $store_obj = "$ini->{wdStore}"->new(
%{ $ini->{wdStorePar} }
@@ -33,16 +34,33 @@ my $handler = sub {
store => $store_obj,
cv => $cv,
);
-# warn "use $env->{wdSession}, $ini->{wdEngine}";
+
+ #determine root document
+ my $env_var = $env->{HTTP_WDINDEXFILE} || $ENV{wdIndexFile} || $ENV{WD_INDEXFILE};
+ my %ini_pars = ();
+ if ( $env_var && !-z $env_var ) {
+ my ($filename) = grep { -r $_ && -f $_ } $env_var;
+ die "$0 ERR:: file not found or can't access (WD_INDEXFILE): $env_var"
+ unless $filename;
+
+ open FH, "<$filename" or die $!;
+ my $content ='';
+ { local $/=undef;
+ $content = <FH>;
+ }
+ close FH;
+ my $lex = new WebDAO::Lex:: tmpl => $content;
+ $ini_pars{lex} = $lex;
+ }
my $eng = "$ini->{wdEngine}"->new(
%{ $ini->{wdEnginePar} },
+ %ini_pars,
session => $sess,
);
#set default header
-# $sess->set_header("content-Type" => 'text/html; charset=utf-8');
$sess->ExecEngine($eng);
- use Data::Dumper;
- $cv->{fd}->write('<pre>'.Dumper($env).'</pre>');
+# use Data::Dumper;
+# $cv->{fd}->write('<pre>'.Dumper($env).'</pre>');
#close psgi
$cv->{fd}->close() if exists $cv->{fd};
$sess->destroy;
View
83 t/02_WebDAO::Response.t
@@ -5,10 +5,39 @@
# change 'tests => 1' to 'tests => last_test_to_print';
-use Test::More ( tests => 39 );
+package Test::Writer;
+
+sub new {
+ my $class = shift;
+ my $self = bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
+}
+sub write { ${ $_[0]->{out} } . $_[1] }
+sub close { }
+sub headers { return $_[0]->{headers} }
+
+1;
+
+package main;
+
+use Test::More ( tests => 35 );
use Data::Dumper;
use strict;
+
+sub make_cv {
+ my %args = @_;
+ my $out;
+ my $cv = WebDAO::CV->new(
+ env => $args{env},
+ writer => sub {
+ new Test::Writer::
+ out => \$out,
+ status => $_[0]->[0],
+ headers => $_[0]->[1];
+ }
+ );
+}
+
BEGIN {
use_ok('WebDAO');
use_ok('WebDAO::Store::Abstract');
@@ -21,55 +50,46 @@ ok my $store_ab = ( new WebDAO::Store::Abstract:: ), "Create store";
ok my $session = ( new WebDAO::SessionSH:: store => $store_ab ),
"Create session";
$session->U_id($ID);
-isa_ok my $response =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj ),
+isa_ok my $response = ( new WebDAO::Response:: cv => &make_cv ),
'WebDAO::Response', 'create object';
-isa_ok $response->_cv_obj, 'WebDAO::CVcgi', 'check cv class';
+isa_ok $response->_cv_obj, 'WebDAO::CV', 'check cv class';
-isa_ok my $resp1 = $response->set_header( "-status", '403 Forbidden' ),
- 'WebDAO::Response', 'check type set_header';
-is_deeply { '-STATUS' => '403 Forbidden' }, $response->_headers,
- 'check _headers';
-isa_ok $resp1->set_header( -type => 'text/html; charset=utf-8' ),
+isa_ok my $resp1 = $response->set_status( 403),
'WebDAO::Response', 'check type set_header';
-is_deeply {
- '-TYPE' => 'text/html; charset=utf-8',
- '-STATUS' => '403 Forbidden'
- },
- $response->_headers, 'check _headers after set set_header';
+is $response->status, 403, 'check $responce->status';
ok !$response->_is_headers_printed, 'check flg _is_headers_printed before';
-isa_ok $response->print_header, 'WebDAO::Response', 'check type print_header';
-ok $response->_is_headers_printed, 'check flg _is_headers_printed before';
isa_ok my $response1 =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj )
+ ( new WebDAO::Response:: cv => &make_cv )
->redirect2url('http://test.com'), 'WebDAO::Response',
'test redirect2url';
-is_deeply { '-LOCATION' => 'http://test.com', '-STATUS' => '302 Found' },
+is_deeply { 'Location' => 'http://test.com'},
$response1->_headers, 'check redirect2url headers';
+
isa_ok my $response2 =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj )
+ ( new WebDAO::Response:: cv => &make_cv )
->set_cookie(
- -name => 'name1',
- -value => 'test1',
- -path => "/path1"
+ name => 'name1',
+ value => 'test1',
+ path => "/path1"
)->set_cookie(
- -name => 'name2',
- -value => 'test2',
- -path => "/path2"
+ name => 'name2',
+ value => 'test2',
+ path => "/path2"
),
'WebDAO::Response', 'test set_cookie';
-ok ref $response2->get_header('-cookie'), "check get_header('-cookie')";
-ok scalar @{ $response2->get_header('-cookie') } == 2,
+ok ref $response2->get_header('Set-Cookie'), "check get_header('Set-Cookie')";
+is scalar @{ $response2->get_header('Set-Cookie') },2,
"check count cookie == 2";
+
#create test files
my ( $fh, $filename ) = tempfile();
print $fh "test\n";
close $fh;
isa_ok my $response3 =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj )
+ ( new WebDAO::Response:: cv => &make_cv )
->send_file( $filename, -type => 'image/jpeg' ), 'WebDAO::Response',
'test send_file';
ok $response3->_is_file_send, 'check $response3->_is_file_send';
@@ -77,6 +97,7 @@ ok $response3->_is_need_close_fh, 'check $response3->_is_need_close_fh';
is $response3->get_mime_for_filename('test.jpg'), 'image/jpeg',
'get_mime_for_filename("test.jpg")';
+
ok !$response3->_is_flushed, 'check $response3->_is_flushed before flush';
isa_ok $response3->flush, 'WebDAO::Response', '$response3->flush';
ok $response3->_is_flushed, 'check $response3->_is_flushed after flush';
@@ -84,7 +105,7 @@ ok $response3->_is_flushed, 'check $response3->_is_flushed after flush';
my $test_call_back1 = 1;
my $test_call_back2 = 2;
isa_ok my $response4 =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj )
+ ( new WebDAO::Response:: cv => &make_cv )
->set_callback( sub { $test_call_back1++ } )
->set_callback( sub { $test_call_back2++ } ), 'WebDAO::Response',
'test set_callaback';
@@ -93,7 +114,7 @@ is $test_call_back1, 2, '$test_call_back1';
is $test_call_back2, 3, '$test_call_back2';
isa_ok my $response5 =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj ),
+ ( new WebDAO::Response:: cv => &make_cv ),
'WebDAO::Response', 'get format';
is $response5->wantformat(), 'html', 'check default wantformat';
@@ -101,7 +122,7 @@ ok $response5->wantformat('html'), 'check wantformat("html") eq html';
ok !$response5->wantformat('csv'), 'check wantformat("csv") ne csv';
isa_ok my $response6 =
- ( new WebDAO::Response:: session => $session, cv => $session->Cgi_obj )->wantformat(json=>1),
+ ( new WebDAO::Response:: cv => &make_cv )->wantformat(json=>1),
'WebDAO::Response', 'set force wantformat(json=>1)';
is $response6->wantformat(), 'json', 'check default wantformat for forced json';
ok !$response6->wantformat('html'), 'check wantformat("html") eq html for forced json';
View
119 t/16_cv.t
@@ -7,13 +7,14 @@
#$Id$
package Test::Writer;
+
sub new {
my $class = shift;
my $self = bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
}
-sub write { ${ $_[0]->{out} } . $_[1] }
-sub close { }
-sub headers { return { @{ $_[0]->{headers} } } }
+sub write { ${ $_[0]->{out} } . $_[1] }
+sub close { }
+sub headers { return $_[0]->{headers} }
1;
@@ -21,22 +22,24 @@ use strict;
use warnings;
sub make_cv {
-my %args = @_;
-my $out;
-my $cv = WebDAO::CV->new(
- env => $args{env},
- writer => sub {
- new Test::Writer::
- out => \$out,
- status => $_[0]->[0],
- headers => $_[0]->[1];
- }
-);
-
+ my %args = @_;
+ my $out;
+ my $cv = WebDAO::CV->new(
+ env => $args{env},
+ writer => sub {
+ new Test::Writer::
+ out => \$out,
+ status => $_[0]->[0],
+ headers => $_[0]->[1];
+ }
+ );
+
}
-#use Test::More tests => 1; # last test to print
-use Test::More 'no_plan';
+
+use Test::More tests => 12; # last test to print
use_ok('WebDAO::CV');
+use_ok('WebDAO::Response');
+
my $out = '';
my $fcgi = WebDAO::CV->new(
env => {
@@ -48,7 +51,7 @@ my $fcgi = WebDAO::CV->new(
'HTTP_ACCEPT' =>
'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8',
'HTTP_COOKIE' => 'tesrt=val; Yert=Terst',
-
+
},
writer => sub {
new Test::Writer::
@@ -79,67 +82,31 @@ my $wr = $fcgi->print_headers();
is_deeply $wr->{headers},
[ 'Content-Type' => 'text/html; charset=utf-8' ], "set headers";
is $wr->{status}, 200, 'Status: 200';
-
-use_ok('WebDAO::Response0');
my $cv1 = &make_cv;
-my $r = new WebDAO::Response0:: cv=>$cv1;
+my $r = new WebDAO::Response:: cv => $cv1;
$r->content_type('text/html; charset=utf-8');
$r->content_length(2345);
-$r->set_cookie({name=>'test', value=>1});
-use Data::Dumper;
-
-diag Dumper ($r->print_header()->_headers);
-is_deeply $r->print_header()->_headers , {
- 'Content-Length' => 2345,
- 'Content-Type' => 'text/html; charset=utf-8'
- };
-
-exit;
-
-
-
-use CGI;
-my $c = new CGI;
-my $q1 = $c->cookie( {
- -NAME => "srote",
- -EXPIRES => "+3M",
- -PATH => "/Err",
- -VALUE => { "1"=>"2", "ewe"=>1}
- }
-);
-my $q2 = $c->cookie( {
- -NAME => "olol",
- -EXPIRES => "+3M",
- -PATH => "/",
- -VALUE => "oh"
- }
-);
-my $q3 = $c->cookie( {
- -NAME => "olol",
- -EXPIRES => "+3M",
- -PATH => "/",
- -VALUE => "ohhhhhh"
- }
-);
-use Data::Dumper;
-diag Dumper $q2;
-diag $c->header(-cookie=>[$q1, $q2, $q3]);
-diag Dumper $cv1->{fd}->headers;
-
-package WebDAO::CV;
-use Data::Dumper;
-
-=head2 get_cookie
-
-=cut
-
-sub get_cookie {
- my $self = shift;
-}
+$r->set_cookie( name => 'test', value => 1 );
+$r->set_cookie( name => 'test1', value => 2, expires => 1327501188 );
+$r->print_header();
+is_deeply $r->_cv_obj->{fd}->headers,
+ [
+ 'Content-Length' => 2345,
+ 'Content-Type' => 'text/html; charset=utf-8',
+ 'Set-Cookie' => 'test=1; path=/',
+ 'Set-Cookie' => 'test1=2; path=/ ;expires=Wed, 25-Jan-2012 14:19:48 GMT'
+ ],
+ 'Set Cookies';
+
+my $cv2 = $fcgi;
+
+is_deeply $cv2->get_cookie(),{
+ 'tesrt' => 'val',
+ 'Yert' => 'Terst'
+ }, "Get cookie";
+
+#package WebDAO::CV;
+#use Data::Dumper;
1;
-
-#use CGI;;
-#print CGI->new()->header(-status=>'200 Not Found');
-
View
3  t/lib/T/Engine.pm
@@ -217,7 +217,6 @@ sub t02_output : Test(7) {
my $out = $t->{OUT};
$eng->execute2( $sess, "/extra2/elem/String" );
is $$out, '<STRI/>', "/extra2/elem/String - call method";
-
$$out = '';
$eng->execute2( $sess, "/extra2/elem/" );
is $$out, 'FF', "/extra2/elem/ - return self";
@@ -240,7 +239,6 @@ sub t03_modal_comp : Test(10) {
my $t = shift;
my $eng = $t->{tlib}->eng;
my $tlib = $t->{tlib};
-
ok my $obj = $eng->_createObj( 'elem', 'TElem' ), 'make TestComp';
$eng->_add_childs_($obj);
@@ -262,6 +260,7 @@ sub t03_modal_comp : Test(10) {
# }
# ]
# };
+
my $out = $t->{OUT};
my $sess = $eng->_session;
$eng->execute2( $sess, "/Mcomp/" );
View
18 t/lib/Test.pm
@@ -39,7 +39,7 @@ sub SKIP_CLASS {
sub setup : Test(setup=>2) {
my $t = shift;
ok( ( my $store_ab = new WebDAO::Store::Abstract:: ), "Create store" );
- my $buffer;
+ my $buffer='';
$t->{OUT}=\$buffer;
my $cv = new TestCV:: \$buffer;
ok( ( my $session = new WebDAO::SessionSH:: store => $store_ab, cv=>$cv ),
@@ -54,21 +54,5 @@ sub teardown : Test(teardown) {
my $t = shift;
delete $t->{tlib};
}
-
-=pod
-sub startup : Test(startup=>+2) {
- my $t = shift;
- ok( ( my $store_ab = new WebDAO::Store::Abstract:: ), "Create store" );
- my $buffer;
- $t->{OUT}=\$buffer;
- my $cv = new TestCV:: \$buffer;
- ok( ( my $session = new WebDAO::SessionSH:: store => $store_ab, cv=>$cv ),
- "Create session" );
- $session->U_id("sdsd");
- my $eng = new WebDAO::Engine:: session => $session;
- $t->{tlib} = new WebDAO::Test eng => $eng;
- undef
-}
-=cut
1;
View
7 t/test_util.t
@@ -9,8 +9,8 @@
use strict;
use warnings;
-#use Test::More tests => 1; # last test to print
-use Test::More 'no_plan';
+use Test::More tests => 4; # last test to print
+#use Test::More 'no_plan';
use Data::Dumper;
use_ok('WebDAO::Util');
@@ -27,4 +27,5 @@ is_deeply $h1->{wdEnginePar},
},
'parse params';
-diag "$h1->{wdSession}"->new;
+isa_ok "$h1->{wdSession}"->new, 'WebDAO::Session', 'defaults';
+
Please sign in to comment.
Something went wrong with that request. Please try again.