# HG changeset patch # User sergey # Date 1350864567 -14400 # Node ID a02b110da931a759c814d50979003153902523c7 # Parent cd2b1f1210291b2de808f6badf8269f1d730ffe2 refactoring fixed binding to CGI query parameters with multiple values diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/DOM/Transform/QueryToDOM.pm --- a/Lib/IMPL/DOM/Transform/QueryToDOM.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/DOM/Transform/QueryToDOM.pm Mon Oct 22 04:09:27 2012 +0400 @@ -16,8 +16,7 @@ my ($this) = @_; $this->templates->{'CGI'} = \&TransformCGI; - $this->templates->{'CGIWrapper'} = \&TransformCGI; - + $this->delimiter('[.]'); $this->prefix(''); } @@ -31,7 +30,8 @@ my $delim = $this->delimiter; foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { - length (my $value = $query->param($param)) or next; + + my @value = grep length($_), $query->param($param) or next; my @parts = split /$delim/,$param; @@ -46,9 +46,9 @@ } } else { if(defined $index) { - $node->{$name}[$index] = $value; + $node->{$name}[$index] = (@value == 1 ? $value[0] : \@value); } else { - $node->{$name} = $value; + $node->{$name} = (@value == 1 ? $value[0] : \@value); } } } diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/Application.pm --- a/Lib/IMPL/Web/Application.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/Web/Application.pm Mon Oct 22 04:09:27 2012 +0400 @@ -8,6 +8,7 @@ use IMPL::declare { require => { + Locator => 'IMPL::Web::AutoLocator', TAction => 'IMPL::Web::Application::Action', HttpResponse => 'IMPL::Web::HttpResponse', TFactory => '-IMPL::Object::Factory', @@ -20,13 +21,14 @@ 'IMPL::Object::Singleton' => '@_' ], props => [ + baseUrl => PROP_RW, actionFactory => PROP_RW, handlers => PROP_RW | PROP_LIST, security => PROP_RW, options => PROP_RW, requestCharset => PROP_RW, - fetchRequestMethod => PROP_RW, - output => PROP_RW + output => PROP_RW, + location => PROP_RO ] }; @@ -37,9 +39,10 @@ "At least one handler should be supplied" ) unless $this->handlers->Count; + $this->baseUrl('/') unless $this->baseUrl; + $this->actionFactory(TAction) unless $this->actionFactory; - $this->fetchRequestMethod( \&defaultFetchRequest ) - unless $this->fetchRequestMethod; + $this->location(Locator->new(base => $this->baseUrl)); } sub Run { @@ -125,86 +128,8 @@ } sub FetchRequest { - my ($this) = @_; - - if ( ref $this->fetchRequestMethod eq 'CODE' ) { - return $this->fetchRequestMethod->($this); - } - else { - die new IMPL::Exception( - "Unknown fetchRequestMethod type", - ref $this->fetchRequestMethod - ); - } -} - -{ - my $hasFetched = 0; - - sub defaultFetchRequest { - my ($this) = @_; - return undef if $hasFetched; - $hasFetched = 1; - $this->output(*STDOUT); - my $query = CGIWrapper->new(); - $query->charset($this->requestCharset) if $this->requestCharset; - return $query; - } -} - -sub defaultErrorHandler { - my ( $this, $action, $e ) = @_; - warn $e; - if ( eval { $action->ReinitResponse(); 1; } ) { - $action->response->contentType('text/plain'); - $action->response->charset( $this->responseCharset ); - $action->response->status(500); - my $hout = $action->response->streamBody; - print $hout $e; - $action->response->Complete(); - } -} - -package CGIWrapper; -use parent qw(CGI); - -use Encode; - -our $NO_DECODE = 0; - -sub param { - my $this = shift; - - return $this->SUPER::param(@_) if $NO_DECODE; - - if (wantarray) { - my @result = $this->SUPER::param(@_); - - return map Encode::is_utf8($_) - ? $_ - : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result; - } - else { - my $result = $this->SUPER::param(@_); - - return Encode::is_utf8($result) - ? $result - : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC ); - } - -} - -sub upload { - my $this = shift; - - local $NO_DECODE = 1; - my $oldCharset = $this->charset(); - $this->charset('ISO-8859-1'); - - my $fh = $this->SUPER::upload(@_); - - $this->charset($oldCharset); - return $fh; + + return; } 1; @@ -215,7 +140,7 @@ =head1 NAME -C Класс для создания экземпляров приложения +C Базовай класс для создания экземпляров приложения =head1 SYNOPSIS @@ -241,4 +166,6 @@ обработчиков. Цепочка обработчиков вызывается снизу вверх, при этом каждый обработчик самостоятельно рекурсивно вызывает следующий (более высокого уровня). +См. также C + =cut diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/Application/Action.pm --- a/Lib/IMPL/Web/Application/Action.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/Web/Application/Action.pm Mon Oct 22 04:09:27 2012 +0400 @@ -12,12 +12,15 @@ ], props => [ application => PROP_RO, - query => PROP_RO + query => PROP_RO, + context => PROP_RW ] }; sub CTOR { my ($this) = @_; + + $this->context({}); } sub cookie { diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/Application/Resource.pm --- a/Lib/IMPL/Web/Application/Resource.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/Web/Application/Resource.pm Mon Oct 22 04:09:27 2012 +0400 @@ -4,6 +4,7 @@ use IMPL::Const qw(:prop); use IMPL::declare { require => { + ViewResult => 'IMPL::Web::ViewResult', Exception => 'IMPL::Exception', ArgumentException => '-IMPL::InvalidArgumentException', OperationException => '-IMPL::InvalidOperationException', @@ -50,6 +51,8 @@ allow => join( ',', map( uc, keys %{ $this->contract->verbs } ) ) ) unless $operation; + + $action->context->{resourceLocation} = $this->location; return $operation->Invoke( $this, $action ); } diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/AutoLocator.pm --- a/Lib/IMPL/Web/AutoLocator.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/Web/AutoLocator.pm Mon Oct 22 04:09:27 2012 +0400 @@ -1,8 +1,11 @@ package IMPL::Web::AutoLocator; use strict; +use overload '""' => 'toString'; + use IMPL::Const qw(:prop); -use IMPL::lang qw( :hash ); +use IMPL::lang qw(:hash); +use IMPL::clone qw(clone); use URI; use URI::Escape; use IMPL::declare { @@ -23,6 +26,12 @@ ] }; +sub Clone { + my $this = shift; + + return clone($this); +} + sub Child { my $this = shift; my $child = shift or die ArgumentException->new("a child resource identifier is required"); @@ -64,6 +73,10 @@ return $url; } +sub toString { + shift->url->as_string(); +} + sub AUTOLOAD { our $AUTOLOAD; diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/CGIApplication.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/CGIApplication.pm Mon Oct 22 04:09:27 2012 +0400 @@ -0,0 +1,37 @@ +package IMPL::Web::CGIApplication; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + CGIWrapper => 'IMPL::Web::CGIWrapper' + }, + base => [ + 'IMPL::Web::Application' => '@_' + ], + props => [ + _queryFetched => PROP_RW + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->output(\*STDOUT) unless $this->output; +} + +sub FetchRequest { + my ($this) = @_; + + return if $this->_queryFetched; + + my $query = CGIWrapper->new(); + + $query->charset($this->requestCharset) if $this->requestCharset; + + $this->_queryFetched(1); + + return $query; +} + +1; \ No newline at end of file diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/CGIWrapper.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/CGIWrapper.pm Mon Oct 22 04:09:27 2012 +0400 @@ -0,0 +1,75 @@ +package IMPL::Web::CGIWrapper; +use strict; + +use parent qw(CGI); +use Encode; + +our $NO_DECODE = 0; + +sub param { + my $this = shift; + + return $this->SUPER::param(@_) if $NO_DECODE; + + if (wantarray) { + my @result = $this->SUPER::param(@_); + + return map Encode::is_utf8($_) + ? $_ + : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result; + } + else { + my $result = $this->SUPER::param(@_); + + return Encode::is_utf8($result) + ? $result + : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC ); + } + +} + +sub upload { + my $this = shift; + + local $NO_DECODE = 1; + my $oldCharset = $this->charset(); + $this->charset('ISO-8859-1'); + + my $fh = $this->SUPER::upload(@_); + + $this->charset($oldCharset); + return $fh; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C - обетрка вокруг стандартного объекта C + +=head1 DESCRIPTION + +Наследуется от C, и переопределяет метод C для декодирования +строковых параметров. В остальном функциональность аналогична стандартному +модулю C. + +=head1 MEMBERS + +=head2 C<$NO_DECODE> + +Глобальная переменная для отключения декодирования параметров. + +=begin code + +{ + local $IMPL::Web::CGIWrapper::NO_DECODE = 1; + my $raw = $q->param('binary'); +} + +=end code + +=cut \ No newline at end of file diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/Handler/RestController.pm --- a/Lib/IMPL/Web/Handler/RestController.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/Web/Handler/RestController.pm Mon Oct 22 04:09:27 2012 +0400 @@ -4,6 +4,7 @@ use IMPL::Const qw(:prop); use IMPL::declare { require => { + Locator => 'IMPL::Web::AutoLocator', ResourceInterface => 'IMPL::Web::Application::ResourceInterface', Exception => 'IMPL::Exception', ArgumentExecption => '-IMPL::InvalidArgumentException', @@ -15,7 +16,7 @@ 'IMPL::Object::Serializable' => undef }, props => [ - rootResource => PROP_RO, + resourceFactory => PROP_RO, trailingSlash => PROP_RO ] }; @@ -23,8 +24,9 @@ sub CTOR { my ($this) = @_; - die ArgumentException->new(rootResource => "A web-resource is required") - unless eval { $this->rootResource->isa(ResourceInterface) }; + die ArgumentException->new(resourceFactory => "A web-resource is required") + unless $this->resourceFactory; + #unless eval { $this->resourceFacotry->isa(ResourceInterface) }; } @@ -59,7 +61,10 @@ my @segments = $this->GetResourcePath($action); - my $res = $this->rootResource; + my $res = $this->resourceFactory->new( + id => 'root', + location => Locator->new(base => $action->application->baseUrl) + ); while(@segments) { my $id = shift @segments; diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/Handler/TTView.pm --- a/Lib/IMPL/Web/Handler/TTView.pm Fri Oct 19 02:23:15 2012 +0400 +++ b/Lib/IMPL/Web/Handler/TTView.pm Mon Oct 22 04:09:27 2012 +0400 @@ -48,7 +48,8 @@ $view = ViewResult->new(model => $model); } - + $view->location($action->context->{resourceLocation}) unless $view->location; + my $vars = { view => $view, model => $model, diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/QueryHandler/JsonFormat.pm --- a/Lib/IMPL/Web/QueryHandler/JsonFormat.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,126 +0,0 @@ -use strict; -package IMPL::Transform::Json; - -package IMPL::Web::QueryHandler::JsonFormat; -use parent qw(IMPL::Web::QueryHandler); -use Error qw(:try); -use JSON; - -sub Process { - my ($this,$action,$nextHandler) = @_; - - my $result; - - try { - $result = $nextHandler->(); - $result = [$result] unless ref $result; - } otherwise { - my $err = shift; - $result = { error => $err }; - }; - - my $t = new IMPL::Transform::Json($action->context->{json}); - - if ($action->context->{transactionType} and $action->context->{transactionType} eq 'form') { - delete @$result{qw(formData formSchema)}; - my $errors = @$result{formErrors}; - - $result->{formErrors} = [ map $_->Message, @$errors ] if $errors; - } - - $action->response->contentType('text/javascript'); - - my $hout = $action->response->streamBody; - print $hout to_json( $t->Transform($result), {pretty => 1} ); -} - -package IMPL::Transform::Json; - -use parent qw(IMPL::Transform); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use Scalar::Util qw(refaddr); - -BEGIN { - private _direct property _visited => prop_none; -} - -my %propListCache; - -our %CTOR = ( - 'IMPL::Transform' => sub { - my $options = shift; - ( - $options ? %{$options} : () - ), - ARRAY => sub { - my ($this,$object) = @_; - - return [ - map { $this->Transform($_) } @$object - ]; - }, - HASH => sub { - my ($this,$object) = @_; - - return { - map { $_, $this->Transform($object->{$_}) } keys %$object - }; - }, - 'IMPL::Object::List' => sub { - my ($this,$object) = @_; - - return [ - map { $this->Transform($_) } @$object - ]; - }, - -plain => sub { - $_[1]; - }, - -default => sub { - my ($this,$object) = @_; - - return "$object" unless $object->isa('IMPL::Object::Abstract'); - - if ( $object->isa(typeof IMPL::Exception) ) { - return { - type => $object->typeof, - message => $object->Message, - arguments => $this->Transform(scalar $object->Args) - }; - } - - my $propList = $propListCache{ref $object}; - unless ( $propList ) { - my %props = map { - $_->Name, (ref $_->Mutators ? 0 : ($_->Mutators & prop_list)) - } $object->get_meta('IMPL::Class::PropertyInfo',sub { $_->Access == IMPL::Class::Member::MOD_PUBLIC and $_->Name !~ /^_/}, 1 ); - - $propListCache{ref $object} = $propList = \%props; - } - - return { - map { - $_, $propList->{$_} ? $this->Transform([$object->$_()]) : $this->Transform(scalar $object->$_()); - } keys %$propList - }; - } - } -); - -sub Transform { - my ($this,$object) = @_; - - # small hack to prevent cycling - - return $this->SUPER::Transform($object) unless ref $object; - - if (exists $this->{$_visited}{refaddr $object}) { - return $this->{$_visited}{refaddr $object}; - } else { - $this->{$_visited}{refaddr $object} = undef; - return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object); - } -} - -1; diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/QueryHandler/PageFormat.pm --- a/Lib/IMPL/Web/QueryHandler/PageFormat.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,202 +0,0 @@ -package IMPL::Web::QueryHandler::PageFormat; -use parent qw(IMPL::Web::QueryHandler IMPL::Object::Autofill); -use strict; - -__PACKAGE__->PassThroughArgs; - -use JSON; -use IMPL::Class::Property; -use IMPL::Web::TT::Document; -use Template::Plugin::URL; -use IMPL::Security::Context(); -use File::Spec(); -use HTML::TreeBuilder(); -use URI(); -use Error qw(:try); -use Encode(); - -$Template::Plugin::URL::JOINT = '&'; - -BEGIN { - public property templatesCharset => prop_all; - public property templatesBase => prop_all; - public property includes => prop_all | prop_list; - public property pathinfoPrefix => prop_all; - public property cache => prop_all; - public property preprocess => prop_all; - public property formatOutput => prop_all; - public property template => prop_all; -} - -sub CTOR { - my ($this) = @_; - - $this->templatesCharset('utf-8') unless $this->templatesCharset; - $this->cache(File::Spec->rel2abs($this->cache)) if $this->cache; - $this->templatesBase(File::Spec->rel2abs($this->templatesBase)) if $this->templatesBase; -} - -sub Process { - my ($this,$action,$nextHandler) = @_; - - my $doc = new IMPL::Web::TT::Document(cache => $this->cache, preprocess => $this->preprocess); - - try { - - $this->templatesBase($ENV{DOCUMENT_ROOT}) unless $this->templatesBase; - - my ($requestUri) = split( /\?/, $ENV{REQUEST_URI} ); - - my $pathInfo; - my @root = (''); - my @base; - - if ( $requestUri eq $ENV{SCRIPT_NAME}.$ENV{PATH_INFO} ) { - # CGI with path info, for example - # /base/cgi-bin/myscript.cgi/path/info - # PATH_INFO will be /path/info - $pathInfo = $ENV{PATH_INFO}; - } else { - # usual url, for exmaple - # /base/script.cgi will have PATH_INFO /base/script.cgi - # /base/ will have PATH_INFO /base/index.cgi (if index.cgi is a DirectoryIndex) - $pathInfo = $ENV{PATH_INFO}; - - if (my $rx = $this->pathinfoPrefix) { - $requestUri =~ s/^($rx)//; - $pathInfo =~ s/^($rx)//; - push @root, grep $_, split /\//, $1 if $1; - } - } - - @base = grep $_, split /\//, ($pathInfo ? substr $requestUri,0, -length($pathInfo) : $requestUri); - - local $ENV{PATH_INFO} = $pathInfo; - - my @path = grep $_, split /\//, ($ENV{PATH_INFO} || '') or die new IMPL::Exception("PATH_INFO is empty and no defaultTarget specified" ); - - my @pathContainer = @path; - pop @pathContainer; - - $doc->LoadFile ( - ($this->template || File::Spec->catfile($this->templatesBase,@path)), - $this->templatesCharset, - [$this->templatesBase, $this->includes], - { - result => scalar($nextHandler->()), - action => $action, - app => $action->application, - - absoluteUrl => sub { new URI(join ('/', @root, $_[0]) ) }, - baseUrl => sub { new URI (join ('/', @root, @base, $_[0]) ) }, - relativeUrl => sub { new URI(join ('/', @root, @base, @pathContainer,$_[0]) ) }, - - user => IMPL::Security::Context->current->principal, - session => IMPL::Security::Context->current, - - to_json => \&to_json, - escape_string => sub { $_[0] =~ s/"/"/g; $_[0] }, - } - ); - - $action->response->contentType('text/html'); - my $hOut = $action->response->streamBody; - if ($this->formatOutput == 1) { - my $tree = new HTML::TreeBuilder(); - try { - $tree->parse_content($doc->Render()); - print $hOut $tree->as_HTML('<>&'," ",{}); - } finally { - $tree->delete; - }; - } elsif ($this->formatOutput() == 2 ) { - (my $data = $doc->Render()) =~ s/\s+/ /g; - print $hOut $data; - } else { - print $hOut $doc->Render(); - } - } finally { - $doc->Dispose; - }; -} - -sub URI::_query::new_params { - my ($this,$params) = @_; - - my $clone = $this->clone; - if (ref $params eq 'HASH' ) { - my %newParams = ($clone->query_form , %$params); - $clone->query_form(map { $_, ( Encode::is_utf8( $newParams{$_} ) ? Encode::encode('utf-8', $newParams{$_}) : $newParams{$_} ) } sort keys %newParams ); - } - return $clone; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C - Выдача результатов в виде HTML страницы, построенной из шаблона. - -=head1 SYNOPSIS - -В файле конфигурации приложения - -=begin code xml - - - - utf-8 - - - -=end code xml - -Программно - -=begin code - -my $app = new IMPL::Web::Application(); -$app->handlersQuery->Add( - new IMPL::Web::QueryHandler::PageFormat( charsetTemplates=> 'utf-8' ); -); - -=end - -=head1 DESCRIPTION - -Обработчик запроса для веб приложения. Загружает шаблон, путь к котрому берется -из C относительно пути из свойства C. - -Наследуется от C для реализации функционала -обработчика запроса и переопределяет метод C. - -C - -=head1 MEMBERS - -=over - -=item C - -Создает новый экземпляр и заполняет свойства. - -=item C<[get,set] templatesCharset> - -Кодировка шаблонов. По умолчанию utf-8. - -=item C<[get,set] templatesBase> - -Каталог относительно которого ищется шаблон. - -=item C<[override] Process($action,$nextHandler)> - -Метод, переопределяющий CProcess> и которому передается управление -для выполнения действий. - -=back - -=cut diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/QueryHandler/PathInfoRewrite.pm --- a/Lib/IMPL/Web/QueryHandler/PathInfoRewrite.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -package IMPL::Web::QueryHandler::PathInfoRewrite; -use strict; - -use parent qw(IMPL::Web::QueryHandler); -__PACKAGE__->PassThroughArgs; - -use IMPL::Class::Property; - -BEGIN { - public property pathinfoPrefix => prop_all; -} - -sub Process { - my ($this,$query,$nextHandler) = @_; - - my $pathInfo = $ENV{PATH_INFO}; - if (my $rx = $this->pathinfoPrefix) { - $pathInfo =~ s/^($rx)//; - } - - local $ENV{PATH_INFO} = $pathInfo; - - scalar $nextHandler->(); -} - -1; diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/QueryHandler/SecureCookie.pm --- a/Lib/IMPL/Web/QueryHandler/SecureCookie.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,115 +0,0 @@ -package IMPL::Web::QueryHandler::SecureCookie; -use strict; - -use parent qw(IMPL::Web::QueryHandler); -use Digest::MD5 qw(md5_hex); - -use IMPL::Class::Property; -use IMPL::Security::Auth qw(:Const); -use IMPL::Security; - -BEGIN { - public property salt => prop_all; -} - -sub CTOR { - my ($this) = @_; - - $this->salt('DeadBeef') unless $this->salt; -} - -sub Process { - my ($this,$action,$nextHandler) = @_; - - return undef unless $nextHandler; - - local $IMPL::Security::authority = $this; - - my $method = $action->query->cookie('method') || 'simple'; - - if ($method eq 'simple') { - - my $sid = $action->query->cookie('sid'); - my $cookie = $action->query->cookie('sdata'); - my $sign = $action->query->cookie('sign'); - - if ( - $sid and - $cookie and - $sign and - $sign eq md5_hex( - $this->salt, - $sid, - $cookie, - $this->salt - ) - ) { - # TODO: add a DefferedProxy to deffer a request to a data source - my $context = $action->application->security->sourceSession->find( - { id => $sid } - ) or return $nextHandler->(); - - my ($result,$challenge) = $context->auth->ValidateSession($cookie); - - if ($result == AUTH_SUCCESS) { - $context->authority($this); - return $context->Impersonate($nextHandler); - } else { - return $nextHandler->(); - } - } else { - return $nextHandler->(); - } - } else { - return $nextHandler->(); - } -} - -sub WriteResponse { - my ($this,$response,$sid,$cookie,$method) = @_; - - my $sign = md5_hex( - $this->salt, - $sid, - $cookie, - $this->salt - ); - - $response->setCookie(sid => $sid); - $response->setCookie(sdata => $cookie); - $response->setCookie(sign => $sign); - $response->setCookie(method => $method) if $method; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C - -=head1 DESCRIPTION - -C - -Возобновляет сессию пользователя на основе информации переданной через Cookie. - -Использует механизм подписи информации для проверки верности входных данных перед -началом каких-либо действий. - -Данный обработчик возвращает результат выполнения следдующего обработчика. - -=head1 MEMBERS - -=over - -=item C<[get,set] salt> - -Скаляр, использующийся для подписи данных. - -=back - -=cut diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/QueryHandler/UrlController.pm --- a/Lib/IMPL/Web/QueryHandler/UrlController.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ -package IMPL::Web::QueryHandler::UrlController; -use strict; -use parent qw(IMPL::Web::QueryHandler); - -use IMPL::Class::Property; -use IMPL::Exception; -use Carp qw(croak); -use Scalar::Util qw(tainted); - -BEGIN { - public property namespace => prop_all; -} - -__PACKAGE__->PassThroughArgs; - -sub Process { - my ($this,$action,$nextHandler) = @_; - - my $namespace = $this->namespace || $action->application->typeof; - - my @target = grep $_, split /\//, ($ENV{PATH_INFO} || '') or die new IMPL::Exception("No target specified"); - - my $method = pop @target; - if ( $method =~ /^(\w+)/ ) { - $method = $1; - } else { - die new IMPL::Exception("Invalid method name",$method); - } - - (/^(\w+)$/ or die new IMPL::Exception("Invalid module name part", $_)) and $_=$1 foreach @target; - - my $module = join '::',$namespace,@target; - - die new IMPL::Exception("A module name is untrusted", $module) if tainted($module); - - eval "require $module; 1;" unless eval{ $module->can('InvokeAction'); }; - if (my $err = $@ ) { - die new IMPL::Exception("Failed to load module",$module,$err); - } - - if(UNIVERSAL::can($module,'InvokeAction')) { - $module->InvokeAction($method,$action); - } else { - die new IMPL::InvalidOperationException("Failed to invoke action",$ENV{PATH_INFO},$module,$method); - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C - вызов метода на основе C запроса. - -=head1 DESCRIPTION - -Использует переменную C<$ENV{PATH_INFO}> для получения имени и метода модуля. -Например запрос C интерпретируется как вызов метода C -у модуля C. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get,set] namespace> - -Пространство имен в котором находится модуль. по умолчению совпадает с именем класса приложения, например C - -=back - -=cut diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/TT/Collection.pm --- a/Lib/IMPL/Web/TT/Collection.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -package IMPL::Web::TT::Collection; -use strict; - -use parent qw(IMPL::DOM::Node); - -__PACKAGE__->PassThroughArgs; - -our $AUTOLOAD; -sub AUTOLOAD { - my $this = shift; - my ($method) = ($AUTOLOAD =~ /(\w+)$/); - - return if $method eq 'DESTROY'; - - if ( @_ >= 1 ) { - # set - - if ($method =~ /^add(\w+)/) { - my ($name,$args) = @_; - return $this->appendChild($this->document->CreateControl($name,$1,$args)); - } - - # we can't assing a node, so this is a dynamic property - return $this->nodeProperty($method,@_); - } else { - # get - # try a dynamic property first - if ( my $val = $this->nodeProperty($method) ) { - return $val; - } else { - # and return a first child node as last opportunity - my @result = $this->selectNodes($method); - - return $result[0] if @result; - } - } - - return; -} - -1; diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/TT/Control.pm --- a/Lib/IMPL/Web/TT/Control.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -package IMPL::Web::TT::Control; - -use parent qw(IMPL::Web::TT::Collection); - - -use IMPL::Class::Property; -use IMPL::DOM::Property qw(_dom); - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public property controlClass => prop_all; - public property template => prop_all; - public property id => prop_all; -} - -my $nextId = 1; - -sub CTOR { - my ($this,%args) = @_; - - if ($this->document) { - # load a template - $this->template( $this->document->context->template($args{template})) if ($args{template} and not ref $args{template}); - } - #$this->template($args{template}) if $args{template}; - - $this->id($this->nodeName . '-' . $nextId++); - $this->controlClass('Control') unless $this->controlClass; -} - -sub Render { - my ($this) = @_; - - if ($this->document) { - if ($this->template) { - return $this->document->context->include($this->template,{ this => $this }) ; - } elsif ($this->document->presenter) { - return $this->document->presenter->print($this); - } else { - return $this->toString().": ".$this->controlClass() . ": ".$this->path; - } - } -} -1; diff -r cd2b1f121029 -r a02b110da931 Lib/IMPL/Web/TT/Document.pm --- a/Lib/IMPL/Web/TT/Document.pm Fri Oct 19 02:23:15 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,381 +0,0 @@ -package IMPL::Web::TT::Document; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Document IMPL::Object::Disposable); -use Template::Context; -use Template::Provider; -use IMPL::Class::Property; -use File::Spec; -use Scalar::Util qw(blessed); -use IMPL::Web::TT::Collection; -use IMPL::Web::TT::Control; -use Carp; -use Encode(); -use Data::Dumper; - -BEGIN { - private property _provider => prop_all; - private property _context => prop_all; - public property cache => prop_all; - public property template => prop_get | owner_set; - public property presenter => prop_all, { validate => \&_validatePresenter }; - public property preprocess => prop_all | prop_list, - public property title => prop_all; - private property _controlClassMap => prop_all; -} - -our %CTOR = ( - 'IMPL::DOM::Document' => sub { nodeName => 'document' } -); - -sub CTOR { - my ($this,%args) = @_; - - $this->_controlClassMap({}); - $this->registerControlClass( Control => 'IMPL::Web::TT::Control' ); - $this->appendChild( $this->Create(body => 'IMPL::Web::TT::Collection') ); - $this->appendChild( $this->Create(head => 'IMPL::Web::TT::Collection') ); - $this->cache($args{cache}) if $args{cache}; - $this->preprocess($args{preprocess}) if $args{preprocess}; -} - -sub CreateControl { - my ($this,$name,$class,$args) = @_; - - $args = {} unless ref $args eq 'HASH'; - - if (my $info = $this->_controlClassMap->{$class}) { - my %nodeArgs = (%{$info->{args}},%$args); - $nodeArgs{controlClass} = $class; - - return $this->Create($name,$info->{type},\%nodeArgs); - } else { - die new IMPL::Exception('A control is\'t registered', $class, $name); - } -} - -sub provider { - my ($this,%args) = @_; - - if (my $provider = $this->_provider) { - return $provider; - } else { - return $this->_provider(new Template::Provider( - \%args - )); - } -} - -sub context { - my ($this) = @_; - - if (my $ctx = $this->_context) { - return $ctx; - } else { - return $this->_context ( - new Template::Context( - VARIABLES => { - document => $this, - this => $this, - render => sub { - $this->_process(@_); - }, - encode => sub { - Encode::encode('utf8',shift); - }, - dump => sub { - Dumper(shift); - }, - as_list => sub { - [ map ref($_) eq 'ARRAY' ? @$_ : $_, @_ ] - } - }, - RECURSION => 1, - LOAD_TEMPLATES => [$this->provider] - ) - ) - } -} - -sub resolveVar { - my ($this,$var) = @_; - - return $this->context->stash->get($var); -} - -sub registerControlClass { - my ($this, $controlClass, $type, $args) = @_; - - $type ||= 'IMPL::Web::TT::Control'; - - die new IMPL::InvalidArgumentException("A controlClass must be a single word",$controlClass) unless $controlClass =~ /^\w+$/; - - eval "require $type; 1;" or die new IMPL::Exception("Failed to load a module",$type,"$@") unless eval { $type->can('new') }; - - die new IMPL::InvalidArgumentException("A type must be subclass of IMPL::DOM::Node",$type) unless $type->isa('IMPL::DOM::Node'); - - # resolve template name to a real template - $args->{template} = $this->context->template($args->{template}) if $args->{template}; - - $this->_controlClassMap->{$controlClass} = { - controlClass => $controlClass, - type => $type, - args => ref $args eq 'HASH' ? $args : {} - }; -} - -sub require { - my ($this,$template) = @_; - - my $doc = $this->context->template($template); - - die new IMPL::InvalidOperationException("A specified template isn't a document",$template) unless eval{ $doc -> isa('Template::Document') }; - - my $controlClass = $doc->class; - my $type = $doc->nativeType; - my $controlTemplate; - my $out = ""; - - die new IMPL::InvalidOperationException("A specified template isn't a control",$template) unless $controlClass; - - if (not $this->isControlClass($controlClass)) { - if ($doc->template) { - $controlTemplate = $doc->blocks()->{$doc->template} || $this->context->template($doc->template); - $out = $this->context->include($doc); - } else { - $controlTemplate = $doc; - } - $this->registerControlClass($controlClass,$type,{ template => $controlTemplate } ); - } - - return $out; -} - -sub isControlClass { - my ($this,$name) = @_; - return $this->_controlClassMap->{$name} ? 1 : 0; -} - -sub _getControls { - my ($this) = @_; - - my ($node) = $this->selectNodes('controls'); - return $node; -} - -sub _validatePresenter { - my ($this,$value) = @_; - - die new IMPL::InvalidArgumentException("A view object is required") unless blessed($value) and $value->isa('Template::View'); -} - -sub LoadFile { - my ($this,$src,$encoding,$includes,$vars) = @_; - - die new IMPL::InvalidArgumentException("A template parameter is required") unless $src; - - $includes = [$includes] if $includes and not ref $includes; - - $encoding ||= 'utf8'; - - $this->_context(undef); - $this->_provider(undef); - - if (not ref $src) { - my ($vol,$dir,$fileName) = File::Spec->splitpath($src); - unshift @$includes, File::Spec->catpath($vol,$dir,''); - $src = $fileName; - } - - $this->provider( - ENCODING => $encoding, - INTERPOLATE => 1, - PRE_CHOMP => 1, - POST_CHOMP => 1, - TRIM => 0, - COMPILE_EXT => $this->cache ? '.ttc' : undef, - COMPILE_DIR => $this->cache, - INCLUDE_PATH => $includes - ); - - if ($vars) { - while ( my ($var,$val) = each %$vars ) { - $this->AddVar($var,$val); - } - } - - $this->context->process($_) foreach $this->preprocess; - - my $template = $this->context->template($src); - $this->title($template->title); - if ( $template->template ) { - $this->context->process($template); - $this->template($template->template); - } else { - $this->template($template); - } - -} - -sub AddVar { - my ($this,$name,$value) = @_; - - $this->context->stash->set($name,$value); -} - -sub Render { - my ($this) = @_; - - return $this->context->process($this->template); -} - -# Формирует представление для произвольных объектов -sub _process { - my ($this,@items) = @_; - - my @result; - - foreach my $item (@items) { - if (blessed($item) and $item->isa('IMPL::Web::TT::Control')) { - push @result, $item->Render(); - } elsif(blessed($item)) { - if ($this->presenter) { - push @result, $this->presenter->print($item); - } else { - push @result, $this->toString; - } - } else { - push @result, $item; - } - } - - return join '',@result; -} - -our $AUTOLOAD; -sub AUTOLOAD { - my $this = shift; - my ($method) = ($AUTOLOAD =~ /(\w+)$/); - - if($method =~ /^create(\w+)/) { - my ($name,$args) = @_; - return $this->CreateControl($name,$1,$args); - } - - my @result = $this->selectNodes($method); - - return $result[0] if @result; - carp "Looks like you have a mistake, the document doesn't have a such property or child: $method"; - return; -} - -sub Dispose { - my ($this) = @_; - - $this->template(undef); - $this->_context(undef); - $this->_provider(undef); - - $this->supercall::Dispose(); -} - -1; -__END__ -=pod - -=head1 NAME - -C - Документ, позволяющий строить представление по шаблону - -=head1 SYNOPSIS - -=begin code - -// create new document -my $doc = new IMPL::Web::TT::Document; - -// load template -$doc->loadFile('Templates/index.tt'); - -// render file -print $doc->Render(); - -=end code - -=head1 DESCRIPTION - -C - -Документ, основанный на шаблоне Template::Toolkit. Позволяет загрузить шаблон, -и сформировать окончательный документ. Является наследником C, -т.о. может быть использован для реализации DOM модели. - -Внутри шаблона переменная C ссылается на объект документа. По этой -причине образуется циклическая ссылка между объектами шаблона и документом, что -требует вызова метода C для освобождения документа. - -=head1 METHODS - -=over - -=item C - -Создает новый экземпляр документа, свойство C устанавливается в 'C' - -=item C<$doc->LoadFile($fileName,$encoding)> - -Загружает шаблон из файла C<$fileName>, используя кодировку C<$encoding>. Если -кодировка не указана, использует utf-8. - -=item C<$doc->Render()> - -Возвращает данные построенные на основе загруженного шаблона. - -=item C<$doc->Dispose()> - -Освобождает ресурсы и помечает объект как освобожденный. - -=back - -=head1 DOM - -Документ представляет собой DOM документ, состоящий из узлов, которые представляют собой данные -для отображения. Для форматированого вывода используется C